App-MHFS/lib/App/MHFS.pm
#!/usr/bin/perl
# Media HTTP File Server
# load this conditionally as it will faile if syscall.ph doesn't exist
BEGIN {
use constant HAS_EventLoop_Poll_Linux_Timer => eval {
package MHFS::EventLoop::Poll::Linux::Timer {
use strict; use warnings;
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use POSIX qw/floor/;
use Devel::Peek;
use feature 'say';
use Config;
if(index($Config{archname}, 'x86_64-linux') == -1) {
die("Unsupported arch: " . $Config{archname});
}
use constant {
_clock_REALTIME => 0,
_clock_MONOTONIC => 1,
_clock_BOOTTIME => 7,
_clock_REALTIME_ALARM => 8,
_clock_BOOTTIME_ALARM => 9,
_ENOTTY => 25, #constant for Linux?
};
# x86_64 numbers
require 'syscall.ph';
my $TFD_CLOEXEC = 0x80000;
my $TFD_NONBLOCK = 0x800;
sub new {
my ($class, $evp) = @_;
my $timerfd = syscall(SYS_timerfd_create(), _clock_MONOTONIC, $TFD_NONBLOCK | $TFD_CLOEXEC);
$timerfd != -1 or die("failed to create timerfd: $!");
my $timerhandle = IO::Handle->new_from_fd($timerfd, "r");
$timerhandle or die("failed to turn timerfd into a file handle");
my %self = ('timerfd' => $timerfd, 'timerhandle' => $timerhandle);
bless \%self, $class;
$evp->set($self{'timerhandle'}, \%self, POLLIN);
$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;
} # package
}; # eval
}; # BEGIN
# You must provide event handlers for the events you are listening for
# return undef to have them removed from poll's structures
package MHFS::EventLoop::Poll::Base {
use strict; use warnings;
use feature 'say';
use POSIX ":sys_wait_h";
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use Scalar::Util qw(looks_like_number);
use Data::Dumper;
use Devel::Peek;
#use Devel::Refcount qw( refcount );
use constant POLLRDHUP => 0;
use constant ALWAYSMASK => (POLLRDHUP | POLLHUP);
sub _decode_status {
my ($rc) = @_;
print "$rc: normal exit with code ". WEXITSTATUS($rc)."\n" if WIFEXITED( $rc);
print "$rc: terminated with signal ".WTERMSIG( $rc)."\n" if WIFSIGNALED($rc);
print "$rc: stopped with signal ". WSTOPSIG( $rc)."\n" if WIFSTOPPED( $rc);
}
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;
}
sub getEvents {
my ($self, $handle) = @_;
return $self->{'poll'}->mask($handle);
}
sub remove {
my ($self, $handle) = @_;
$self->{'poll'}->remove($handle);
$self->{'fh_map'}{$handle} = undef;
}
sub _insert_timer {
my ($self, $timer) = @_;
my $i;
for($i = 0; defined($self->{'timers'}[$i]) && ($timer->{'desired'} >= $self->{'timers'}[$i]{'desired'}); $i++) { }
splice @{$self->{'timers'}}, $i, 0, ($timer);
return $i;
}
# all times are relative, is 0 is set as the interval, it will be run every main loop iteration
# return undef in the callback to delete the timer
sub add_timer {
my ($self, $start, $interval, $callback, $id) = @_;
my $current_time = clock_gettime(CLOCK_MONOTONIC);
my $desired = $current_time + $start;
my $timer = { 'desired' => $desired, 'interval' => $interval, 'callback' => $callback };
$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);
}
}
sub check_timers {
my ($self) = @_;
my @requeue_timers;
my $timerhit = 0;
my $current_time = clock_gettime(CLOCK_MONOTONIC);
while(my $timer = shift (@{$self->{'timers'}}) ) {
if($current_time >= $timer->{'desired'}) {
$timerhit = 1;
if(defined $timer->{'callback'}->($timer, $current_time, $self)) { # callback may change interval
push @requeue_timers, $timer;
}
}
else {
unshift @{$self->{'timers'}}, $timer;
last;
}
}
$self->requeue_timers(\@requeue_timers, $current_time);
}
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;
}
do_poll($self, $loop_interval, $poll);
}
}
1;
}
package MHFS::EventLoop::Poll::Linux {
use strict; use warnings;
use feature 'say';
use parent -norequire, 'MHFS::EventLoop::Poll::Base';
sub new {
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;
}
package MHFS::EventLoop::Poll {
use strict; use warnings;
use feature 'say';
my $selbackend;
BEGIN {
my @backends;
if(main::HAS_EventLoop_Poll_Linux_Timer) {
push @backends, "-norequire, 'MHFS::EventLoop::Poll::Linux'";
}
push @backends, "-norequire, 'MHFS::EventLoop::Poll::Base'";
foreach my $backend (@backends) {
if(eval "use parent $backend; 1;") {
$selbackend = $backend;
last;
}
}
$selbackend or die("Failed to load MHFS::EventLoop::Poll backend");
}
sub backend {
return $selbackend;
}
1;
}
package MHFS::HTTP::Server {
use strict; use warnings;
use feature 'say';
use IO::Socket::INET;
use Socket qw(IPPROTO_TCP TCP_KEEPALIVE TCP_NODELAY);
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Scalar::Util qw(weaken);
use File::Path qw(make_path);
use Data::Dumper;
use Config;
MHFS::Util->import();
sub new {
my ($class, $launchsettings, $plugins, $routes) = @_;
$SIG{PIPE} = sub {
print STDERR "SIGPIPE @_\n";
};
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?
#$SERVER->setsockopt(SOL_SOCKET, SO_LINGER, pack("II",1,0)) or die; #to stop last ack
# leaving Nagle's algorithm enabled for now as sometimes headers are sent without data
#$sock->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1) or die("Failed to set TCP_NODELAY");
# linux specific settings. Check in BEGIN?
if(index($Config{osname}, 'linux') != -1) {
use Socket qw(TCP_QUICKACK);
$sock->setsockopt(IPPROTO_TCP, TCP_QUICKACK, 1) or die("Failed to set TCP_QUICKACK");
}
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}) {
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;
}
sub GetResource {
my ($self, $filename) = @_;
$self->{'resources'}{$filename} //= MHFS::Util::read_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 = MHFS::Util::ParseIPv4($peerhost);
if(! defined $peerip) {
say "server: error parsing ip";
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;
}
package MHFS::Util {
use strict; use warnings;
use feature 'say';
use Exporter 'import';
use File::Find;
use File::Basename;
use POSIX ();
use Cwd qw(abs_path getcwd);
use Encode qw(decode encode);
use URI::Escape qw(uri_escape uri_escape_utf8);
use MIME::Base64 qw(encode_base64url decode_base64url);
our @EXPORT = ('LOCK_GET_LOCKDATA', 'LOCK_WRITE', 'UNLOCK_WRITE', 'write_file', 'read_file', 'shellcmd_unlock', 'ASYNC', 'FindFile', 'space2us', 'escape_html', 'function_exists', 'shell_escape', 'pid_running', 'escape_html_noquote', 'output_dir_versatile', 'do_multiples', 'getMIME', 'get_printable_utf8', 'small_url_encode', 'uri_escape_path', 'uri_escape_path_utf8', 'round', 'ceil_div', 'get_SI_size', 'decode_UTF_8', 'encode_UTF_8', 'str_to_base64url', 'base64url_to_str');
# single threaded locks
sub LOCK_GET_LOCKDATA {
my ($filename) = @_;
my $lockname = "$filename.lock";
my $bytes = read_file($lockname);
if(! defined $bytes) {
return undef;
}
return $bytes;
}
#sub LOCK_GET_FILESIZE {
# my ($filename) = @_;
# my $lockedfilesize = LOCK_GET_LOCKDATA($filename);
# if(defined $lockedfilesize) {
#
# }
#}
sub LOCK_WRITE {
my ($filename, $lockdata) = @_;
my $lockname = "$filename.lock";
if(-e $lockname) {
return 0;
}
$lockdata //= "99999999999"; #99 Billion
write_file($lockname, $lockdata);
return 1;
}
sub UNLOCK_WRITE {
my ($filename) = @_;
my $lockname = "$filename.lock";
unlink($lockname);
}
sub write_file {
my ($filename, $text) = @_;
open (my $fh, '>', $filename) or die("$! $filename");
print $fh $text;
close($fh);
}
sub read_file {
my ($filename) = @_;
return do {
local $/ = undef;
if(!(open my $fh, "<", $filename)) {
#say "could not open $filename: $!";
return undef;
}
else {
<$fh>;
}
};
}
# This is not fast
sub FindFile {
my ($directories, $name_req, $path_req) = @_;
my $curdir = getcwd();
my $foundpath;
eval {
my $dir_matches = 1;
my %options = ('wanted' => sub {
return if(! $dir_matches);
if(/$name_req/i) {
return if( -d );
$foundpath = $File::Find::name;
die;
}
});
if(defined $path_req) {
$options{'preprocess'} = sub {
$dir_matches = ($File::Find::dir =~ /$path_req/i);
return @_;
};
}
find(\%options, @$directories);
};
chdir($curdir);
return $foundpath;
}
sub shellcmd_unlock {
my ($command_arr, $fullpath) = @_;
system @$command_arr;
UNLOCK_WRITE($fullpath);
}
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 {
my ($string) = @_;
my %dangerchars = ( '"' => '"', "'" => ''', '<' => '<', '>' => '>', '/' => '/');
$string =~ s/&/&/g;
foreach my $key(keys %dangerchars) {
my $val = $dangerchars{$key};
$string =~ s/$key/$val/g;
}
return \$string;
}
sub escape_html_noquote {
my ($string) = @_;
my %dangerchars = ('<' => '<', '>' => '>');
$string =~ s/&/&/g;
foreach my $key(keys %dangerchars) {
my $val = $dangerchars{$key};
$string =~ s/$key/$val/g;
}
return \$string;
}
sub function_exists {
no strict 'refs';
my $funcname = shift;
return \&{$funcname} if defined &{$funcname};
return;
}
sub pid_running {
return kill 0, shift;
}
sub shell_escape {
my ($cmd) = @_;
($cmd) =~ s/'/'"'"'/g;
return $cmd;
}
sub output_dir_versatile {
my ($path, $options) = @_;
# hide the root path if desired
my $root = $options->{'root'};
$options->{'min_file_size'} //= 0;
my @files;
ON_DIR:
# get the list of files and sort
my $dir;
if(! opendir($dir, $path)) {
warn "outputdir: Cannot open directory: $path $!";
return;
}
my @newfiles = sort { uc($a) cmp uc($b)} (readdir $dir);
closedir($dir);
my @newpaths = ();
foreach my $file (@newfiles) {
next if($file =~ /^..?$/);
push @newpaths, "$path/$file";
}
@files = @files ? (@newpaths, undef, @files) : @newpaths;
while(@files)
{
$path = shift @files;
if(! defined $path) {
$options->{'on_dir_end'}->() if($options->{'on_dir_end'});
next;
}
my $file = basename($path);
if(-d $path) {
$options->{'on_dir_start'}->($path, $file) if($options->{'on_dir_start'});
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
sub do_multiples {
my ($multiples, $result_func) = @_;
my %data;
my @mkeys = keys %{$multiples};
foreach my $multiple (@mkeys) {
my $multiple_cb = sub {
my ($res) = @_;
$data{$multiple} = $res;
# return failure if this multiple failed
if(! defined $data{$multiple}) {
$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',
'flac' => 'audio/flac',
'opus' => 'audio',
'ogg' => 'audio/ogg',
'wav' => 'audio/wav',
# video
'mp4' => 'video/mp4',
'ts' => 'video/mp2t',
'mkv' => 'video/x-matroska',
'webm' => 'video/webm',
'flv' => 'video/x-flv',
# media
'mpd' => 'application/dash+xml',
'm3u8' => 'application/x-mpegURL',
'm3u8_v' => 'application/x-mpegURL',
# text
'html' => 'text/html; charset=utf-8',
'json' => 'application/json',
'js' => 'application/javascript',
'txt' => 'text/plain',
'css' => 'text/css',
# images
'jpg' => 'image/jpeg',
'jpeg' => 'image/jpeg',
'png' => 'image/png',
'gif' => 'image/gif',
'bmp' => 'image/bmp',
# binary
'pdf' => 'application/pdf',
'tar' => 'application/x-tar',
'wasm' => 'application/wasm',
'bin' => 'application/octet-stream'
);
my ($ext) = $filename =~ /\.([^.]+)$/;
# default to binary
return $combined{$ext} // $combined{'bin'};
}
sub ParseIPv4 {
my ($ipstring) = @_;
my @values = $ipstring =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
if(scalar(@values) != 4) {
return undef;
}
foreach my $i (0..3) {
($values[$i] <= 255) or return undef;
}
return ($values[0] << 24) | ($values[1] << 16) | ($values[2] << 8) | ($values[3]);
}
sub surrogatepairtochar {
my ($hi, $low) = @_;
my $codepoint = 0x10000 + (ord($hi) - 0xD800) * 0x400 + (ord($low) - 0xDC00);
return pack('U', $codepoint);
}
sub surrogatecodepointpairtochar {
my ($hi, $low) = @_;
my $codepoint = 0x10000 + ($hi - 0xD800) * 0x400 + ($low - 0xDC00);
return pack('U', $codepoint);
}
# returns the byte length and the codepoint
sub peek_utf8_codepoint {
my ($octets) = @_;
my @rules = (
[0xE0, 0xC0, 2], # 2 byte sequence
[0xF0, 0xE0, 3], # 3 byte sequence
[0XF8, 0xF0, 4] # 4 byte sequence
);
length($$octets) >= 1 or return undef;
my $byte = substr($$octets, 0, 1);
my $byteval = ord($byte);
my $charlen = 1;
foreach my $rule (@rules) {
if(($byteval & $rule->[0]) == $rule->[1]) {
$charlen = $rule->[2];
last;
}
}
length($octets) >= $charlen or return undef;
my $char = decode("utf8", substr($$octets, 0, $charlen));
if(length($char) > 1) {
return {'codepoint' => 0xFFFD, 'bytelength' => 1};
}
return { 'codepoint' => ord($char), 'bytelength' => $charlen};
}
sub get_printable_utf8 {
my ($octets) = @_;
#my $cp = ((0xF0 & 0x07) << 18) | ((0x9F & 0x3F) << 12) | ((0x8E & 0x3F) << 6) | (0x84 & 0x3F);
#say "codepoint $cp";
#
#my @tests = (
## #(chr(1 << 7) . chr(1 << 7)),
## #chr(0xED).chr(0xA0).chr(0xBC),
## #chr(0xED).chr(0xA0).chr(0xBC) . chr(1 << 7) . chr(1 << 7),
## #chr(0xED).chr(0xED).chr(0xED),
## chr(0xF0).chr(0xBF).chr(0xBF).chr(0xBF),
## chr(0xED).chr(0xA0),
## chr(0xF0).chr(0x9F).chr(0x8E).chr(0x84),
## chr(0xF0).chr(0x9F).chr(0x8E),
# chr(0xF0).chr(0x9F).chr(0x8E).chr(0x84),
# chr(0xF0).chr(0x9F).chr(0x8E).chr(0x04),
# chr(0x7F),
# chr(0xC1).chr(0x80),
# chr(0xC2).chr(0x80)
#);
##
#foreach my $test (@tests) {
# my $unsafedec = decode("utf8", $test, Encode::LEAVE_SRC);
# my $safedec = decode('UTF-8', $test);
# say "udec $unsafedec len ".length($unsafedec)." sdec $safedec len ".length($safedec);
# say "udec codepoint ".ord($unsafedec)." sdec codepoint " . ord($safedec);
#}
#die;
my $res;
while(length($octets)) {
$res .= decode('UTF-8', $octets, Encode::FB_QUIET);
last if(!length($octets));
# by default replace with the replacement char
my $chardata = peek_utf8_codepoint(\$octets);
my $toappend = chr(0xFFFD);
my $toremove = $chardata->{'bytelength'};
# if we find a surrogate pair, make the actual codepoint
if(($chardata->{'bytelength'} == 3) && ($chardata->{'codepoint'} >= 0xD800) && ($chardata->{'codepoint'} <= 0xDBFF)) {
my $secondchar = peek_utf8_codepoint(\substr($octets, 3, 3));
if($secondchar && ($secondchar->{'bytelength'} == 3) && ($secondchar->{'codepoint'} >= 0xDC00) && ($secondchar->{'codepoint'} <= 0xDFFF)) {
$toappend = surrogatecodepointpairtochar($chardata->{'codepoint'}, $secondchar->{'codepoint'});
$toremove += 3;
}
}
$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) = @_;
uri_escape_utf8($path, qr/[^A-Za-z0-9\-\._~\/]/)
}
sub round {
return int($_[0]+0.5);
}
sub ceil_div {
return int(($_[0] + $_[1] - 1) / $_[1]);
}
sub get_SI_size {
my ($bytes) = @_;
my $mebibytes = ($bytes / 1048576);
if($mebibytes >= 1024) {
return sprintf("%.2f GiB", $bytes / 1073741824);
}
else {
return sprintf("%.2f MiB", $mebibytes);
}
}
sub decode_UTF_8 {
my ($input) = @_;
my $output = decode('UTF-8', $input, Encode::FB_QUIET);
if (length($input)) {
return undef;
}
return $output;
}
sub encode_UTF_8 {
my ($input) = @_;
my $b_output = encode('UTF-8', $input, Encode::FB_QUIET);
if (length($input)) {
return undef;
}
$b_output
}
sub str_to_base64url {
my ($str) = @_;
my $bstr = encode('UTF-8', $str, Encode::FB_DEFAULT);
encode_base64url($bstr)
}
sub base64url_to_str {
my ($base64url) = @_;
my $bstr = decode_base64url($base64url);
decode_UTF_8($bstr)
}
1;
}
package MHFS::Promise::FakeException {
sub new {
my ($class, $reason) = @_;
return bless \$reason, $class;
}
1;
}
package MHFS::Promise {
use strict; use warnings;
use feature 'say';
use constant {
MHFS_PROMISE_PENDING => 0,
MHFS_PROMISE_SUCCESS => 1,
MHFS_PROMISE_FAILURE => 2,
MHFS_PROMISE_ADOPT => 3
};
sub finale {
my ($self) = @_;
my $success = $self->{state} == MHFS_PROMISE_SUCCESS;
foreach my $item (@{$self->{waiters}}) {
$self->handle($item);
}
$self->{waiters} = [];
}
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;
}
sub new {
my ($class, $evp, $cb) = @_;
my $self = _new(@_);
$cb->($self->{fulfill}, $self->{reject});
return $self;
}
sub throw {
return MHFS::Promise::FakeException->new(@_);
}
sub handleResolved {
my ($self, $deferred) = @_;
$self->{evp}->add_timer(0, 0, sub {
my $success = $self->{state} == MHFS_PROMISE_SUCCESS;
my $value = $self->{end_value};
if($success && $deferred->{onFulfilled}) {
$value = $deferred->{onFulfilled}($value);
if(ref($value) eq 'MHFS::Promise::FakeException') {
$success = 0;
$value = $$value;
}
} elsif(!$success && $deferred->{onRejected}) {
$value = $deferred->{onRejected}->($value);
if(ref($value) ne 'MHFS::Promise::FakeException') {
$success = 1;
} else {
$value = $$value;
}
}
if($success) {
$deferred->{promise}{fulfill}->($value);
} else {
$deferred->{promise}{reject}->($value);
}
return undef;
});
}
sub handle {
my ($self, $deferred) = @_;
while($self->{state} == MHFS_PROMISE_ADOPT) {
$self = $self->{end_value};
}
if($self->{state} == MHFS_PROMISE_PENDING) {
push(@{$self->{'waiters'}}, $deferred);
} else {
$self->handleResolved($deferred);
}
}
sub then {
my ($self, $onFulfilled, $onRejected) = @_;
my $promise = MHFS::Promise->_new($self->{evp});
my %handler = ( 'promise' => $promise, onFulfilled => $onFulfilled, onRejected => $onRejected);
$self->handle(\%handler);
return $promise;
}
1;
}
package MHFS::HTTP::Server::Client::Request {
MHFS::Util->import();
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use URI::Escape;
use Cwd qw(abs_path getcwd);
use File::Basename;
use File::stat;
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Data::Dumper;
use Scalar::Util qw(weaken);
use List::Util qw[min max];
use Symbol 'gensym';
use Devel::Peek;
use Encode qw(decode encode);
use constant {
MAX_REQUEST_SIZE => 8192,
};
use FindBin;
use File::Spec;
BEGIN {
if( ! (eval "use JSON; 1")) {
eval "use JSON::PP; 1" or die "No implementation of JSON available";
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
}
}
# Optional dependency, Alien::Tar::Size
BEGIN {
use constant HAS_Alien_Tar_Size => (eval "use Alien::Tar::Size; 1");
if(! HAS_Alien_Tar_Size) {
warn "Alien::Tar::Size is not available";
}
}
sub new {
my ($class, $client) = @_;
my %self = ( 'client' => $client);
bless \%self, $class;
weaken($self{'client'}); #don't allow Request to keep client alive
$self{'on_read_ready'} = \&want_request_line;
$self{'outheaders'}{'X-MHFS-CONN-ID'} = $client->{'outheaders'}{'X-MHFS-CONN-ID'};
$self{'rl'} = 0;
# we want the request
$client->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
$self{'recvrequesttimerid'} = $client->AddClientCloseTimer($client->{'server'}{'settings'}{'recvrequestimeout'}, $client->{'CONN-ID'}, 1);
return \%self;
}
# on ready ready handlers
sub want_request_line {
my ($self) = @_;
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);
if(defined $value) {
if(!defined $qsStruct{$key}) {
$qsStruct{$key} = uri_unescape($value);
}
else {
if(ref($qsStruct{$key}) ne 'ARRAY') {
$qsStruct{$key} = [$qsStruct{$key}];
};
push @{$qsStruct{$key}}, uri_unescape($value);
}
}
}
$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'};
$self->{'ip'} = MHFS::Util::ParseIPv4($self->{'header'}{'X-Forwarded-For'}) if($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;
$self->{'client'}->SetEvents(MHFS::EventLoop::Poll->ALWAYSMASK );
$self->{'client'}->KillClientCloseTimer($self->{'recvrequesttimerid'});
$self->{'recvrequesttimerid'} = undef;
# finally handle the request
foreach my $route (@{$self->{'client'}{'server'}{'routes'}}) {
if($self->{'path'}{'unsafecollapse'} eq $route->[0]) {
$route->[1]($self);
return 1;
}
else {
# wildcard ending
next if(index($route->[0], '*', length($route->[0])-1) == -1);
next if(rindex($self->{'path'}{'unsafecollapse'}, substr($route->[0], 0, -1), 0) != 0);
$route->[1]($self);
return 1;
}
}
$self->{'client'}{'server'}{'route_default'}($self);
return 1;
}
# unfortunately the absolute url of the server is required for stuff like m3u playlist generation
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'};
my $code = $opt->{'code'};
if(! $code) {
# if start is defined it's a range request
if(defined $self->{'header'}{'_RangeStart'}) {
$code = 206;
}
else {
$code = 200;
}
}
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;
}
# if the CL isn't known we need to send chunked
if(! defined $contentlength) {
$self->{'outheaders'}{'Transfer-Encoding'} = 'chunked';
}
else {
$self->{'outheaders'}{'Content-Length'} = "$contentlength";
}
my %lookup = (
200 => "HTTP/1.1 200 OK\r\n",
206 => "HTTP/1.1 206 Partial Content\r\n",
301 => "HTTP/1.1 301 Moved Permanently\r\n",
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';
$filename = $opt->{'attachment'};
}
elsif($opt->{'inline'}) {
$filename = $opt->{'inline'};
}
if($filename) {
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";
$dataitem->{'buf'} = $headtext;
if($dataitem->{'fh'}) {
$dataitem->{'fh_pos'} = tell($dataitem->{'fh'});
$dataitem->{'get_current_length'} //= sub { return undef };
}
$self->_SendResponse($dataitem);
}
sub Send403 {
my ($self) = @_;
my $msg = "403 Forbidden\r\n";
$self->SendHTML($msg, {'code' => 403});
}
sub Send404 {
my ($self) = @_;
my $msg = "404 Not Found";
$self->SendHTML($msg, {'code' => 404});
}
sub Send408 {
my ($self) = @_;
my $msg = "408 Request Timeout";
$self->{'outheaders'}{'Connection'} = 'close';
$self->SendHTML($msg, {'code' => 408});
}
sub Send416 {
my ($self, $cursize) = @_;
$self->{'outheaders'}{'Content-Range'} = "*/$cursize";
$self->SendHTML('', {'code' => 416});
}
sub Send503 {
my ($self) = @_;
$self->{'outheaders'}{'Retry-After'} = 5;
my $msg = "503 Service Unavailable";
$self->SendHTML($msg, {'code' => 503});
}
# requires already encoded url
sub SendRedirectRawURL {
my ($self, $code, $url) = @_;
$self->{'outheaders'}{'Location'} = $url;
my $msg = "UNKNOWN REDIRECT MSG";
if($code == 301) {
$msg = "301 Moved Permanently";
}
elsif($code == 307) {
$msg = "307 Temporary Redirect";
}
$msg .= "\r\n<a href=\"$url\"></a>\r\n";
$self->SendHTML($msg, {'code' => $code});
}
# encodes path and querystring
# path and query string keys and values must be bytes not unicode string
sub SendRedirect {
my ($self, $code, $path, $qs) = @_;
my $url;
# encode the path component
while(length($path)) {
my $slash = index($path, '/');
my $len = ($slash != -1) ? $slash : length($path);
my $pathcomponent = substr($path, 0, $len, '');
$url .= uri_escape($pathcomponent);
if($slash != -1) {
substr($path, 0, 1, '');
$url .= '/';
}
}
# encode the querystring
if($qs) {
$url .= '?';
foreach my $key (keys %{$qs}) {
my @values;
if(ref($qs->{$key}) ne 'ARRAY') {
push @values, $qs->{$key};
}
else {
@values = @{$qs->{$key}};
}
foreach my $value (@values) {
$url .= uri_escape($key).'='.uri_escape($value) . '&';
}
}
chop $url;
}
@_ = ($self, $code, $url);
goto &SendRedirectRawURL;
}
sub SendLocalFile {
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;
$fileitem{'fh'} = $FH;
}
else {
$currentsize = (-s $requestfile);
}
# seek if a start is specified
if(defined $start) {
if($start >= $currentsize) {
$self->Send416($currentsize);
return;
}
elsif($fileitem{'fh'}) {
seek($fileitem{'fh'}, $start, 0);
}
}
# get the maximumly possible file size. 99999999999 signfies unknown
my $get_current_size = sub {
return $currentsize;
};
my $done;
my $ts;
my $get_max_size = sub {
my $locksz = LOCK_GET_LOCKDATA($requestfile);
if($done) {
return $ts;
}
if(defined($locksz)) {
$ts = ($locksz || 0);
}
else {
$done = 1;
$ts = ($get_current_size->() || 0);
}
};
my $filelength = $get_max_size->();
# truncate to the [potentially] satisfiable end
if(defined $self->{'header'}{'_RangeEnd'}) {
$self->{'header'}{'_RangeEnd'} = min($filelength-1, $self->{'header'}{'_RangeEnd'});
}
# setup callback for retrieving current file size if we are following the file
if($fileitem{'fh'}) {
if(! $done) {
$get_current_size = sub {
return stat($fileitem{'fh'})
};
}
my $get_read_filesize = sub {
my $maxsize = $get_max_size->();
if(defined $self->{'header'}{'_RangeEnd'}) {
my $rangesize = $self->{'header'}{'_RangeEnd'}+1;
return $rangesize if($rangesize <= $maxsize);
}
return $maxsize;
};
$fileitem{'get_current_length'} = $get_read_filesize;
}
# flag to add SharedArrayBuffer headers
my @SABwhitelist = ('static/music_worklet_inprogress/index.html');
my $allowSAB;
foreach my $allowed (@SABwhitelist) {
if(index($requestfile, $allowed, length($requestfile)-length($allowed)) != -1) {
$allowSAB = 1;
last;
}
}
# finally build headers and send
if($filelength == 99999999999) {
$filelength = undef;
}
my $mime = getMIME($requestfile);
my $opt = {
'size' => $filelength,
'mime' => $mime,
'allowSAB' => $allowSAB
};
if($self->{'responseopt'}{'cd_file'}) {
$opt->{$self->{'responseopt'}{'cd_file'}} = basename($requestfile);
}
$self->_SendDataItem(\%fileitem, $opt);
}
# currently only supports fixed filelength
sub SendPipe {
my ($self, $FH, $filename, $filelength, $mime) = @_;
if(! defined $filelength) {
$self->Send404();
}
$mime //= getMIME($filename);
binmode($FH);
my %fileitem;
$fileitem{'fh'} = $FH;
$fileitem{'get_current_length'} = sub {
my $tocheck = defined $self->{'header'}{'_RangeEnd'} ? $self->{'header'}{'_RangeEnd'}+1 : $filelength;
return min($filelength, $tocheck);
};
$self->_SendDataItem(\%fileitem, {
'size' => $filelength,
'mime' => $mime,
'filename' => $filename
});
}
# to do get rid of shell escape, launch ssh without blocking
sub SendFromSSH {
my ($self, $sshsource, $filename, $node) = @_;
my @sshcmd = ('ssh', $sshsource->{'userhost'}, '-p', $sshsource->{'port'});
my $fullescapedname = "'" . shell_escape($filename) . "'";
my $folder = $sshsource->{'folder'};
my $size = $node->[1];
my @cmd;
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;
return 1;
}
# buf is a bytes scalar
sub SendBytes {
my ($self, $mime, $buf, $options) = @_;
# we want to sent in increments of bytes not characters
if(Encode::is_utf8($buf)) {
warn "SendBytes: UTF8 flag is set, turning off";
Encode::_utf8_off($buf);
}
my $bytesize = length($buf);
# only truncate buf if responding to a range request
if((!$options->{'code'}) || ($options->{'code'} == 206)) {
my $start = $self->{'header'}{'_RangeStart'} // 0;
my $end = $self->{'header'}{'_RangeEnd'} // $bytesize-1;
$buf = substr($buf, $start, ($end-$start) + 1);
}
# Use perlio to read from the buf
my $fh;
if(!open($fh, '<', \$buf)) {
$self->Send404;
return;
}
my %fileitem = (
'fh' => $fh,
'get_current_length' => sub { return undef }
);
$self->_SendDataItem(\%fileitem, {
'size' => $bytesize,
'mime' => $mime,
'filename' => $options->{'filename'},
'code' => $options->{'code'}
});
}
# expects unicode string (not bytes)
sub SendText {
my ($self, $mime, $buf, $options) = @_;
@_ = ($self, $mime, encode('UTF-8', $buf), $options);
goto &SendBytes;
}
# expects unicode string (not bytes)
sub SendHTML {
my ($self, $buf, $options) = @_;;
@_ = ($self, 'text/html; charset=utf-8', encode('UTF-8', $buf), $options);
goto &SendBytes;
}
# expects perl data structure
sub SendAsJSON {
my ($self, $obj, $options) = @_;
@_ = ($self, 'application/json', encode_json($obj), $options);
goto &SendBytes;
}
sub SendCallback {
my ($self, $callback, $options) = @_;
my %fileitem;
$fileitem{'cb'} = $callback;
$self->_SendDataItem(\%fileitem, {
'size' => $options->{'size'},
'mime' => $options->{'mime'},
'filename' => $options->{'filename'}
});
}
sub SendAsTar {
my ($self, $requestfile) = @_;
if(!HAS_Alien_Tar_Size) {
warn("Cannot send tar without Alien::Tar::Size");
$self->Send404();
return;
}
my ($libtarsize) = Alien::Tar::Size->dynamic_libs;
if(!$libtarsize) {
warn("Cannot find libtarsize");
$self->Send404();
return;
}
# 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;
}
});
},
},
undef, # fd settings
{
'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);
}
else {
$request->Send404;
}
}
# is directory
elsif (-d _) {
# ends with slash
if(index($request->{'path'}{'unescapepath'}, '/', length($request->{'path'}{'unescapepath'})-1) != -1) {
my $index = $requestfile.'/index.html';
if(-f $index) {
$request->SendFile($index);
return;
}
$request->Send404;
}
else {
# redirect to slash path
my $bn = basename($requestfile);
$request->SendRedirect(301, $bn.'/');
}
}
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 {
$self->Send404;
}
return;
}
elsif(-d _) {
# ends with slash
if((substr $self->{'path'}{'unescapepath'}, -1) eq '/') {
opendir ( my $dh, $requestfile ) or die "Error in opening dir $requestfile\n";
my $buf;
my $filename;
while( ($filename = readdir($dh))) {
next if(($filename eq '.') || ($filename eq '..'));
next if(!(-s "$requestfile/$filename"));
my $url = uri_escape($filename);
$url .= '/' if(-d _);
$buf .= '<a href="' . $url .'">'.${escape_html_noquote(decode('UTF-8', $filename, Encode::LEAVE_SRC))} .'</a><br><br>';
}
closedir($dh);
$self->SendHTML($buf);
return;
}
# redirect to slash path
else {
$self->SendRedirect(301, basename($requestfile).'/');
return;
}
}
$self->Send404;
}
sub PUTBuf_old {
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'} = '';
}
$self->{'on_read_ready'} = undef;
$handler->($data);
}
else {
$self->{'client'}{'inbuf'} = '';
}
#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);
}
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;
}
package MHFS::HTTP::Server::Client {
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use IO::Socket::INET;
use Errno qw(EINTR EIO :POSIX);
use Fcntl qw(:seek :mode);
use File::stat;
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Scalar::Util qw(looks_like_number weaken);
use Data::Dumper;
use Carp;
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
sub new {
my ($class, $sock, $server, $serverhostinfo, $ip) = @_;
$sock->blocking(0);
my %self = ('sock' => $sock, 'server' => $server, 'time' => clock_gettime(CLOCK_MONOTONIC), 'inbuf' => '', 'serverhostname' => $serverhostinfo->{'hostname'}, 'absurl' => $serverhostinfo->{'absurl'}, 'ip' => $ip, 'X-MHFS-PROXY-KEY' => $serverhostinfo->{'X-MHFS-PROXY-KEY'});
$self{'CONN-ID'} = int($self{'time'} * rand()); # insecure uid
$self{'outheaders'}{'X-MHFS-CONN-ID'} = sprintf("%X", $self{'CONN-ID'});
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,
CT_YIELD => 1,
CT_DONE => undef,
#CT_READ => 1,
#CT_PROCESS = 2,
#CT_WRITE => 3
};
# The "client_thread" consists of 5 states, CT_READ, CT_PROCESS, CT_WRITE, CT_YIELD, and CT_DONE
# CT_READ reads input data from the socket
## on data read transitions to CT_PROCESS
## on error transitions to CT_DONE
## otherwise CT_YIELD
# CT_PROCESS processes the input data
## on processing done, switches to CT_WRITE or CT_READ to read more data to process
## on error transitions to CT_DONE
## otherwise CT_YIELD
# CT_WRITE outputs data to the socket
## on all data written transitions to CT_PROCESS unless Connection: close is set.
## on error transitions to CT_DONE
## otherwise CT_YIELD
# CT_YIELD just returns control to the poll loop to wait for IO or allow another client thread to run
# 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'})) {
die("went into CT_PROCESS in bad state");
return CT_YIELD;
}
my $res = $self->{'request'}{'on_read_ready'}->($self->{'request'});
if(!$res) {
return $res;
}
if(defined $self->{'request'}{'response'}) {
goto &CT_WRITE;
}
elsif(defined $self->{'request'}{'on_read_ready'}) {
goto &CT_READ;
}
return $res;
}
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 {
# Try to send the buf if set
if(length($dataitem->{'buf'})) {
my $sret = TrySendItem($csock, \$dataitem->{'buf'});
# critical conn error
if(! defined($sret)) {
_TSRReturnPrint($sentthiscall);
return undef;
}
if($sret) {
$sentthiscall += $sret;
# if we sent data, kill the send timer
if(defined $client->{'sendresponsetimerid'}) {
$client->KillClientCloseTimer($client->{'sendresponsetimerid'});
$client->{'sendresponsetimerid'} = undef;
}
}
# not all data sent, add timer
if(length($dataitem->{'buf'}) > 0) {
$client->{'sendresponsetimerid'} //= $client->AddClientCloseTimer($client->{'server'}{'settings'}{'sendresponsetimeout'}, $client->{'CONN-ID'});
_TSRReturnPrint($sentthiscall);
return '';
}
#we sent the full buf
}
# read more data
my $newdata;
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;
}
}
}
elsif(defined $dataitem->{'cb'}) {
$newdata = $dataitem->{'cb'}->($dataitem);
}
my $encode_chunked = $dataitem->{'is_chunked'};
# if we got to here and there's no data, fetching newdata is done
if(! $newdata) {
$dataitem->{'fh'} = undef;
$dataitem->{'cb'} = undef;
$dataitem->{'is_chunked'} = undef;
$newdata = '';
}
# encode chunked encoding if needed
if($encode_chunked) {
my $sizeline = sprintf "%X\r\n", length($newdata);
$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";
}
return undef;
}
elsif($sret) {
substr($$dataref, 0, $sret, '');
}
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;
}
package MHFS::FD::Reader {
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;
}
if($ret == -1) {
return undef;
}
if($ret == 1) {
return 1;
}
}
sub onHangUp {
}
sub DESTROY {
my $self = shift;
print "PID " . $self->{'process'}{'pid'} . ' ' if($self->{'process'});
print "FD " . $self->{'fd'};
say ' reader DESTROY called';
}
1;
}
package MHFS::FD::Writer {
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;
}
if($ret == -1) {
return undef;
}
if($ret == 1) {
return 1;
}
}
sub onHangUp {
}
sub DESTROY {
my $self = shift;
say "PID " . $self->{'process'}{'pid'} . " FD " . $self->{'fd'}.' writer DESTROY called';
}
1;
}
package MHFS::Process {
use strict; use warnings;
use feature 'say';
use Symbol 'gensym';
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use POSIX ":sys_wait_h";
use IO::Socket::INET;
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Errno qw(EINTR EIO :POSIX);
use Fcntl qw(:seek :mode);
use File::stat;
use IPC::Open3;
use Scalar::Util qw(looks_like_number weaken);
use Data::Dumper;
use Devel::Peek;
use Carp;
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
#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;
}
if($fddispatch->{'STDOUT'}) {
$self->{'fd'}{'stdout'} = MHFS::FD::Reader->new($self, $out, $fddispatch->{'STDOUT'});
$evp->set($out, $self->{'fd'}{'stdout'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK());
}
else {
$self->{'fd'}{'stdout'}{'fd'} = $out;
}
if($fddispatch->{'STDERR'}) {
$self->{'fd'}{'stderr'} = MHFS::FD::Reader->new($self, $err, $fddispatch->{'STDERR'});
$evp->set($err, $self->{'fd'}{'stderr'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK);
}
else {
$self->{'fd'}{'stderr'}{'fd'} = $err;
}
if($handlesettings->{'O_NONBLOCK'}) {
# stderr
{
my $flags = fcntl($err, Fcntl::F_GETFL, 0) or die "$!";
fcntl($err, Fcntl::F_SETFL, $flags | Fcntl::O_NONBLOCK) or die "$!";
}
# stdout
{
my $flags = fcntl($out, Fcntl::F_GETFL, 0) or die "$!";
fcntl($out, Fcntl::F_SETFL, $flags | Fcntl::O_NONBLOCK) or die "$!";
}
# stdin
defined($in->blocking(0)) or die($!);
#(0 == fcntl($in, Fcntl::F_GETFL, $flags)) or die("$!");#return undef;
#$flags |= Fcntl::O_NONBLOCK;
#(0 == fcntl($in, Fcntl::F_SETFL, $flags)) or die;#return undef;
return $self;
}
}
sub sigkill {
my ($self, $cb) = @_;
if($cb) {
$self->{'evp'}{'children'}{$self->{'pid'}} = $cb;
}
kill('KILL', $self->{'pid'});
}
sub stopSTDOUT {
my ($self) = @_;
$self->{'evp'}->set($self->{'fd'}{'stdout'}{'fd'}, $self->{'fd'}{'stdout'}, MHFS::EventLoop::Poll->ALWAYSMASK);
}
sub resumeSTDOUT {
my ($self) = @_;
$self->{'evp'}->set($self->{'fd'}{'stdout'}{'fd'}, $self->{'fd'}{'stdout'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK);
}
sub new {
my ($class, $torun, $evp, $fddispatch, $handlesettings, $env) = @_;
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'evp' => $evp);
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'} = '';
$context->{'stderr'} = '';
my $prochandlers = {
'STDOUT' => sub {
my ($handle) = @_;
my $buf;
while(read($handle, $buf, 4096)) {
$context->{'stdout'} .= $buf;
}
if($context->{'on_stdout_data'}) {
$context->{'on_stdout_data'}->($context);
}
return 1;
},
'STDERR' => sub {
my ($handle) = @_;
my $buf;
while(read($handle, $buf, 4096)) {
$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;
}
}
};
}
$process = $make_process->($make_process_args, $prochandlers, {'O_NONBLOCK' => 1});
return $process;
}
# launch a command process with poll handlers
sub _new_cmd {
my ($mpa, $prochandlers, $handlesettings) = @_;
return $mpa->{'class'}->new($mpa->{'cmd'}, $mpa->{'evp'}, $prochandlers, $handlesettings);
}
# launch a command process
sub new_cmd_process {
my ($class, $evp, $cmd, $context) = @_;
my $mpa = {'class' => $class, 'evp' => $evp, 'cmd' => $cmd};
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;
}
close($sockfh);
}
# launch a process without a new exe with just sigchld handler
sub new_output_child {
my ($class, $evp, $func, $handler) = @_;
my $mpa = {'class' => $class, 'evp' => $evp, 'func' => $func};
return _new_ex(\&_new_child, $mpa, {
'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;
}
package MHFS::Settings {
use strict; use warnings;
use feature 'say';
use Scalar::Util qw(reftype);
use MIME::Base64 qw(encode_base64url);
use File::Basename;
use Digest::MD5 qw(md5);
use Storable qw(freeze);
use Cwd qw(abs_path);
use File::ShareDir qw(dist_dir);
use File::Path qw(make_path);
use File::Spec::Functions qw(rel2abs);
MHFS::Util->import();
sub write_settings_file {
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;
}
}
if(! defined $value) {
$raw = 1;
$value = 'undef';
$type = 'SCALAR';
}
elsif($value eq '__indent-') {
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."'";
}
# add the value to the buffer
$settingscontents .= $value;
$settingscontents .= ",\n" if(! $raw);
}
elsif($type eq 'HASH') {
$settingscontents .= "{\n";
$indentspace .= (' ' x $indentcnst);
my @toprepend;
foreach my $key (keys %{$value}) {
push @toprepend, '__raw', "'$key' => ", '__noindent', $value->{$key};
}
push @toprepend, '__indent-', '__raw', "},\n";
unshift(@values, @toprepend);
}
elsif($type eq 'ARRAY') {
$settingscontents .= "[\n";
$indentspace .= (' ' x $indentcnst);
my @toprepend = @{$value};
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_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);
if (exists $sources->{$shortid}) {
my $oldid = calc_source_id($sources->{$shortid});
while(1) {
$len++;
substr($oldid, 0, $len) eq substr($id, 0, $len) or last;
length($id) > $len or die "matching hash";
}
$sources->{substr($oldid, 0, $len)} = $sources->{$shortid};
delete $sources->{$shortid};
$shortid = substr($id, 0, $len);
}
$sources->{$shortid} = $source;
return $shortid;
}
sub load {
my ($launchsettings) = @_;
my $scriptpath = abs_path(__FILE__);
# settings are loaded with the following precedence
# $launchsettings (@ARGV) > settings.pl > General environment vars
# Directory preference goes from declared to defaults and specific to general:
# For example $CFGDIR > $XDG_CONFIG_HOME > $XDG_CONFIG_DIRS > $FALLBACK_DATA_ROOT
# load in the launchsettings
my ($CFGDIR, $APPDIR, $FALLBACK_DATA_ROOT);
if(exists $launchsettings->{CFGDIR}) {
make_path($launchsettings->{CFGDIR});
$CFGDIR = $launchsettings->{CFGDIR};
}
if(exists $launchsettings->{APPDIR}) {
-d $launchsettings->{APPDIR} or die("Bad APPDIR provided");
$APPDIR = $launchsettings->{APPDIR};
}
if(exists $launchsettings->{FALLBACK_DATA_ROOT}) {
make_path($launchsettings->{FALLBACK_DATA_ROOT});
$FALLBACK_DATA_ROOT = $launchsettings->{FALLBACK_DATA_ROOT};
}
# determine the settings dir
if(! $CFGDIR){
my $cfg_fallback = $FALLBACK_DATA_ROOT // $ENV{'HOME'};
$cfg_fallback //= ($ENV{APPDATA}.'/mhfs') if($ENV{APPDATA}); # Windows
# set the settings dir to the first that exists of $XDG_CONFIG_HOME and $XDG_CONFIG_DIRS
# https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html
my $XDG_CONFIG_HOME = $ENV{'XDG_CONFIG_HOME'};
$XDG_CONFIG_HOME //= ($cfg_fallback . '/.config') if($cfg_fallback);
my @configdirs;
push @configdirs, $XDG_CONFIG_HOME if($XDG_CONFIG_HOME);
my $XDG_CONFIG_DIRS = $ENV{'XDG_CONFIG_DIRS'} || '/etc/xdg';
push @configdirs, split(':', $XDG_CONFIG_DIRS);
foreach my $cfgdir (@configdirs) {
if(-d "$cfgdir/mhfs") {
$CFGDIR = "$cfgdir/mhfs";
last;
}
}
$CFGDIR //= ($XDG_CONFIG_HOME.'/mhfs') if($XDG_CONFIG_HOME);
defined($CFGDIR) or die("Failed to find valid candidate for \$CFGDIR");
}
$CFGDIR = rel2abs($CFGDIR);
# load from the settings file
my $SETTINGS_FILE = rel2abs($CFGDIR . '/settings.pl');
my $SETTINGS = do ($SETTINGS_FILE);
if(! $SETTINGS) {
die "Error parsing settingsfile: $@" if($@);
die "Cannot read settingsfile: $!" if(-e $SETTINGS_FILE);
warn("No settings file found, using default settings");
$SETTINGS = {};
}
# load defaults for unset values
$SETTINGS->{'HOST'} ||= "127.0.0.1";
$SETTINGS->{'PORT'} ||= 8000;
$SETTINGS->{'ALLOWED_REMOTEIP_HOSTS'} ||= [
['127.0.0.1'],
];
# 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'} = [];
foreach my $rule (@{$SETTINGS->{'ALLOWED_REMOTEIP_HOSTS'}}) {
# parse IPv4 with optional CIDR
$rule->[0] =~ /^([^\/]+)(?:\/(\d{1,2}))?$/ or die("Invalid rule: " . $rule->[0]);
my $ipstr = $1; my $cidr = $2 // 32;
my $ip = MHFS::Util::ParseIPv4($ipstr);
defined($ip) or die("Invalid rule: " . $rule->[0]);
$cidr >= 0 && $cidr <= 32 or die("Invalid rule: " . $rule->[0]);
my $mask = (0xFFFFFFFF << (32-$cidr)) & 0xFFFFFFFF;
my %ariphost = (
'ip' => $ip,
'subnetmask' => $mask
);
# store the server hostname if verification is required for this rule
$ariphost{'hostname'} = $rule->[1] if($rule->[1]);
# store overriding absurl from this host if provided
if($rule->[2]) {
my $absurl = $rule->[2];
chop $absurl if(index($absurl, '/', length($absurl)-1) != -1);
$ariphost{'absurl'} = $absurl;
}
# store whether to trust connections with this host
if($rule->[3]) {
$ariphost{'X-MHFS-PROXY-KEY'} = $rule->[3];
}
push @{ $SETTINGS->{'ARIPHOSTS_PARSED'}}, \%ariphost;
}
if( ! $SETTINGS->{'DOCUMENTROOT'}) {
$SETTINGS->{'DOCUMENTROOT'} = "$APPDIR/public_html";
}
$SETTINGS->{'XSEND'} //= 0;
my $tmpdir = $SETTINGS->{'TMPDIR'};
$tmpdir ||= ($ENV{'XDG_CACHE_HOME'}.'/mhfs') if($ENV{'XDG_CACHE_HOME'});
$tmpdir ||= "$FALLBACK_DATA_ROOT/.cache/mhfs" if($FALLBACK_DATA_ROOT);
defined($tmpdir) or die("Failed to find valid candidate for \$tmpdir");
delete $SETTINGS->{'TMPDIR'}; # Use specific temp dir instead
if(!$SETTINGS->{'RUNTIME_DIR'} ) {
my $RUNTIMEDIR = $ENV{'XDG_RUNTIME_DIR'};
if(! $RUNTIMEDIR ) {
$RUNTIMEDIR = $tmpdir;
warn("XDG_RUNTIME_DIR not defined!, using $RUNTIMEDIR instead");
}
$SETTINGS->{'RUNTIME_DIR'} = $RUNTIMEDIR.'/mhfs';
}
my $datadir = $SETTINGS->{'DATADIR'};
$datadir ||= ($ENV{'XDG_DATA_HOME'}.'/mhfs') if($ENV{'XDG_DATA_HOME'});
$datadir ||= "$FALLBACK_DATA_ROOT/.local/share/mhfs" if($FALLBACK_DATA_ROOT);
defined($datadir) or die("Failed to find valid candidate for \$datadir");
$SETTINGS->{'DATADIR'} = $datadir;
$SETTINGS->{'MHFS_TRACKER_TORRENT_DIR'} ||= $SETTINGS->{'DATADIR'}.'/torrent';
$SETTINGS->{'VIDEO_TMPDIR'} ||= $tmpdir.'/video';
$SETTINGS->{'MUSIC_TMPDIR'} ||= $tmpdir.'/music';
$SETTINGS->{'GENERIC_TMPDIR'} ||= $tmpdir.'/tmp';
$SETTINGS->{'SECRET_TMPDIR'} ||= $tmpdir.'/secret';
$SETTINGS->{'MEDIALIBRARIES'}{'movies'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/movies",
$SETTINGS->{'MEDIALIBRARIES'}{'tv'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/tv",
$SETTINGS->{'MEDIALIBRARIES'}{'music'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/music",
my %sources;
my %mediasources;
foreach my $lib ('movies', 'tv', 'music') {
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;
my $videotmpdirsrc = {type => 'local', folder => $SETTINGS->{'VIDEO_TMPDIR'}};
my $vtempsrcid = add_source(\%sources, $videotmpdirsrc);
$SETTINGS->{'VIDEO_TMPDIR_QS'} = 'sid='.$vtempsrcid;
$SETTINGS->{'SOURCES'} = \%sources;
$SETTINGS->{'BINDIR'} ||= $APPDIR . '/bin';
$SETTINGS->{'DOCDIR'} ||= $APPDIR . '/doc';
# specify timeouts in seconds
$SETTINGS->{'TIMEOUT'} ||= 75;
# time to recieve the requestline and headers before closing the conn
$SETTINGS->{'recvrequestimeout'} ||= 10;
# maximum time allowed between sends
$SETTINGS->{'sendresponsetimeout'} ||= $SETTINGS->{'TIMEOUT'};
$SETTINGS->{'Torrent'}{'pyroscope'} ||= $FALLBACK_DATA_ROOT .'/.local/pyroscope' if($FALLBACK_DATA_ROOT);
return $SETTINGS;
}
1;
};
package MHFS::BitTorrent::Bencoding {
use strict; use warnings;
use Exporter 'import';
our @EXPORT = ('bencode', 'bdecode');
use feature 'say';
# a node is an array with the first element being the type, followed by the value(s)
# ('int', iv) - integer node, MUST have one integer value, bencoded as iIVe
# ('bstr', bytestring) - byte string node, MUST have one bytestring value, bencoded as bytestringLength:bytestring where bytestringLength is the length as ASCII numbers
# ('l', values) - list node, MAY have one or more values of type int, bstr, list, and dict bencoded as lVALUESe
# ('d', kvpairs) - dict node, special case of list, MAY one or more key and value pairs. A dict node MUST have multiple of 2 values; a bstr key with corespoding value
# ('null', value) - null node, MAY have one value, used internally by bdecode to avoid dealing with the base case of no parent
# ('e') - end node, MUST NOT have ANY values, used internally by bencode to handle writing list/dict end
sub bencode {
my ($node) = @_;
my @toenc = ($node);
my $output;
while(my $node = shift @toenc) {
my $type = $node->[0];
if(($type eq 'd') || ($type eq 'l')) {
$output .= $type;
my @nextitems = @{$node};
shift @nextitems;
push @nextitems, ['e'];
unshift @toenc, @nextitems;
}
elsif($type eq 'bstr') {
$output .= sprintf("%u:%s", length($node->[1]), $node->[1]);
}
elsif($type eq 'int') {
$output .= 'i'.$node->[1].'e';
}
elsif($type eq 'e') {
$output .= 'e';
}
else {
return undef;
}
}
return $output;
}
sub bdecode {
my ($contents, $foffset) = @_;
my @headnode = ('null');
my @nodestack = (\@headnode);
my $startoffset = $foffset;
while(1) {
# a bstr is always valid as it can be a dict key
if(substr($$contents, $foffset) =~ /^(0|[1-9][0-9]*):/) {
my $count = $1;
$foffset += length($count)+1;
my $bstr = substr($$contents, $foffset, $count);
my $node = ['bstr', $bstr];
$foffset += $count;
push @{$nodestack[-1]}, $node;
}
elsif((substr($$contents, $foffset, 1) eq 'e') &&
(($nodestack[-1][0] eq 'l') ||
(($nodestack[-1][0] eq 'd') &&((scalar(@{$nodestack[-1]}) % 2) == 1)))) {
pop @nodestack;
$foffset++;
}
elsif(($nodestack[-1][0] ne 'd') || ((scalar(@{$nodestack[-1]}) % 2) == 0)) {
my $firstchar = substr($$contents, $foffset++, 1);
if(($firstchar eq 'd') || ($firstchar eq 'l')) {
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;
}
package MHFS::BitTorrent::Metainfo {
use strict;
use warnings;
use feature 'say';
use Digest::SHA qw(sha1);
MHFS::BitTorrent::Bencoding->import();
use Data::Dumper;
sub Parse {
my ($srcdata) = @_;
my $tree = bdecode($srcdata, 0);
return undef if(! $tree);
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;
print "\n";
mktor($evp, \@params, $cb);
}
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 {
my ($class, $tree) = @_;
my $infodata = _bdictfind($tree, ['info'], 'd');
return undef if(! $infodata);
my %self = (tree => $tree, 'infohash' => sha1(bencode($infodata)));
bless \%self, $class;
return \%self;
}
1;
}
package MHFS::FS {
use strict; use warnings;
use feature 'say';
use Cwd qw(abs_path);
use File::Basename qw(fileparse);
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 {
my ($filepath, $flocation) = @_;
my ($name, $loc, $ext) = fileparse($filepath, '\.[^\.]*');
$ext =~ s/^\.//;
return { 'filepath' => $filepath, 'name' => $name, 'containingdir' => $loc, 'ext' => $ext, 'fullname' => substr($filepath, length($flocation)+1), 'root' => $flocation};
}
sub new {
my ($class, $sources) = @_;
my %self = ('sources' => $sources);
bless \%self, $class;
return \%self;
}
1;
}
package MHFS::BitTorrent::Client {
use strict; use warnings;
use feature 'say';
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;
}
sub torrent_d_bytes_done {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.bytes_done', $infohash ], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_d_size_bytes {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.size_bytes', $infohash ],sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_load_verbose {
my ($server, $filename, $callback) = @_;
rtxmlrpc($server, ['load.verbose', '', $filename], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_load_raw_verbose {
my ($server, $data, $callback) = @_;
rtxmlrpc($server, ['load.raw_verbose', '', '@-'], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
}, $data);
}
sub torrent_d_directory_set {
my ($server, $infohash, $directory, $callback) = @_;
rtxmlrpc($server, ['d.directory.set', $infohash, $directory], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_d_start {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.start', $infohash], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_d_delete_tied {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.delete_tied', $infohash], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_d_name {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.name', $infohash], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_d_is_multi_file {
my ($server, $infohash, $callback) = @_;
rtxmlrpc($server, ['d.is_multi_file', $infohash], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_set_priority {
my ($server, $infohash, $priority, $callback) = @_;
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.priority.set=' . $priority], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$callback->(undef);
return;
}
rtxmlrpc($server, ['d.update_priorities', $infohash], sub {
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
})});
}
# 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) = @_;
if($output =~ /ERROR/) {
$output = undef;
}
$callback->($output);
});
}
sub torrent_file_information {
my ($server, $infohash, $name, $cb) = @_;
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.path=', 'f.size_bytes='], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$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 {
my ($res) = @_;
if(! defined $res) {
$cb->(undef);
}
if($res == 1) {
%files = ( $name . '/' . $key => $files{$key});
}
$cb->(\%files);
});
return;
}
my %newfiles;
foreach my $key (@fkeys) {
$newfiles{$name . '/' . $key} = $files{$key};
}
$cb->(\%newfiles);
});
}
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;
}
package MHFS::Plugin::MusicLibrary {
use strict; use warnings;
use feature 'say';
use Cwd qw(abs_path getcwd);
use File::Find;
use Data::Dumper;
use Devel::Peek;
use Fcntl ':mode';
use File::stat;
use File::Basename;
use File::Path qw(make_path);
use Scalar::Util qw(looks_like_number);
MHFS::Util->import();
BEGIN {
if( ! (eval "use JSON; 1")) {
eval "use JSON::PP; 1" or die "No implementation of JSON available";
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
}
}
use Encode qw(decode encode);
use URI::Escape;
use Storable qw(dclone);
use Fcntl ':mode';
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use Scalar::Util qw(looks_like_number weaken);
use POSIX qw/ceil/;
use Storable qw( freeze thaw);
#use ExtUtils::testlib;
use FindBin;
use File::Spec;
use List::Util qw[min max];
use HTML::Template;
# Optional dependency, MHFS::XS
BEGIN {
use constant HAS_MHFS_XS => (eval "use MHFS::XS; 1");
if(! HAS_MHFS_XS) {
warn __PACKAGE__.": XS not available";
}
}
# read the directory tree from desk and store
# this assumes filenames are UTF-8ish, the octlets will be the actual filename, but the printable filename is created by decoding it as UTF-8
sub BuildLibrary {
my ($path) = @_;
my $statinfo = stat($path);
return undef if(! $statinfo);
my $basepath = basename($path);
my $utf8name = get_printable_utf8($basepath);
if(!S_ISDIR($statinfo->mode)){
return undef if($path !~ /\.(flac|mp3|m4a|wav|ogg|webm)$/);
return [$basepath, $statinfo->size, undef, $utf8name];
}
else {
my $dir;
if(! opendir($dir, $path)) {
warn "outputdir: Cannot open directory: $path $!";
return undef;
}
my @files = sort { uc($a) cmp uc($b)} (readdir $dir);
closedir($dir);
my @tree;
my $size = 0;
foreach my $file (@files) {
next if(($file eq '.') || ($file eq '..'));
if(my $file = BuildLibrary("$path/$file")) {
push @tree, $file;
$size += $file->[1];
}
}
return undef if( $size eq 0);
return [$basepath, $size, \@tree, $utf8name];
}
}
sub ToHTML {
my ($files, $where) = @_;
$where //= '';
my $buf = '';
my $name_unencoded = $files->[3];
my $name = ${escape_html_noquote($name_unencoded)};
if($files->[2]) {
my $dir = $files->[0];
$buf .= '<tr>';
$buf .= '<td>';
$buf .= '<table border="1" class="tbl_track">';
$buf .= '<tbody>';
$buf .= '<tr class="track">';
$buf .= '<th>' . $name . '</th>';
$buf .= '<th><a href="#">Play</a></th><th><a href="#">Queue</a></th><th><a href="music_dl?action=dl&name=' . uri_escape_utf8($where.$name_unencoded) . '">DL</a></th>';
$buf .= '</tr>';
$where .= $name_unencoded . '/';
foreach my $file (@{$files->[2]}) {
$buf .= ToHTML($file, $where) ;
}
$buf .= '</tbody></table>';
$buf .= '</td>';
}
else {
if($where eq '') {
$buf .= '<table border="1" class="tbl_track">';
$buf .= '<tbody>';
}
$buf .= '<tr class="track">';
$buf .= '<td>' . $name . '</td>';
$buf .= '<td><a href="#">Play</a></td><td><a href="#">Queue</a></td><td><a href="music_dl?action=dl&name=' . uri_escape_utf8($where.$name_unencoded).'">DL</a></td>';
if($where eq '') {
$buf .= '</tr>';
$buf .= '</tbody></table>';
return $buf;
}
}
$buf .= '</tr>';
return $buf;
}
sub toJSON {
my ($self) = @_;
my $head = {'files' => []};
my @nodestack = ($head);
my @files = (@{$self->{'library'}});
while(@files) {
my $file = shift @files;
if( ! $file) {
pop @nodestack;
next;
}
my $node = $nodestack[@nodestack - 1];
my $newnode = {'name' =>$file->[3]};
if($file->[2]) {
$newnode->{'files'} = [];
push @nodestack, $newnode;
@files = (@{$file->[2]}, undef, @files);
}
push @{$node->{'files'}}, $newnode;
}
# encode json outputs bytes NOT unicode string
return encode_json($head);
}
sub LibraryHTML {
my ($self) = @_;
my $buf = '';
foreach my $file (@{$self->{'library'}}) {
$buf .= ToHTML($file);
$buf .= '<br>';
}
my $legacy_template = HTML::Template->new(filename => 'templates/music_legacy.html', path => $self->{'settings'}{'APPDIR'} );
$legacy_template->param(musicdb => $buf);
$self->{'html'} = encode('UTF-8', $legacy_template->output, Encode::FB_CROAK);
$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';
my $fallback = 'musicinc';
if($request->{'header'}{'User-Agent'} =~ /Chrome\/([^\.]+)/) {
my $ver = $1;
# SharedArrayBuffer support with spectre/meltdown fixes was added in 68
# AudioWorklet on linux had awful glitching until somewhere in 92 https://bugs.chromium.org/p/chromium/issues/detail?id=825823
if($ver < 93) {
if(($ver < 68) || ($request->{'header'}{'User-Agent'} =~ /Linux/)) {
$fmt = $fallback;
}
}
}
elsif($request->{'header'}{'User-Agent'} =~ /Firefox\/([^\.]+)/) {
my $ver = $1;
# SharedArrayBuffer support with spectre/meltdown fixes was added in 79
if($ver < 79) {
$fmt = $fallback;
}
}
else {
# Hope for the best, assume worklet works
}
# leave this here for now to not break the segment based players
if($request->{'qs'}{'segments'}) {
$fmt = $fallback;
}
}
# route
my $qs = defined($request->{'qs'}{'ptrack'}) ? {'ptrack' => $request->{'qs'}{'ptrack'}} : undef;
if($fmt eq 'worklet') {
return $request->SendRedirect(307, 'static/music_worklet_inprogress/', $qs);
}
elsif($fmt eq 'musicdbjson') {
return $request->SendBytes('application/json', $self->{'musicdbjson'});
}
elsif($fmt eq 'musicdbhtml') {
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
my ($buf) = @_;
my $metaBinString = unpack('B144', $buf);
my $x32 = 0 x 32;
my $info = {};
$info->{'MINIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 0, 16), -32)));
$info->{'MAXIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 16, 16), -32)));
$info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 32, 24), -32)));
$info->{'MAXIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 56, 24), -32)));
$info->{'SAMPLERATE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 80, 20), -32)));
$info->{'NUMCHANNELS'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 3), -32))) + 1;
$info->{'BITSPERSAMPLE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 103, 5), -32))) + 1;
# Calculate total samples in two parts
my $highBits = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 108, 4), -32)));
$info->{'TOTALSAMPLES'} = $highBits * 2 ** 32 +
unpack('N', pack('B32', substr($x32 . substr($metaBinString, 112, 32), -32)));
# Return the MD5 as a 32-character hexadecimal string
$info->{'MD5CHECKSUM'} = unpack('H32',substr($buf, 18, 16));
return $info;
}
sub GetTrackInfo {
my ($file) = @_;
open(my $fh, '<', $file) or die "open failed";
my $buf = '';
seek($fh, 8, 0) or die "seek failed";
(read($fh, $buf, 34) == 34) or die "short read";
my $info = parseStreamInfo($buf);
$info->{'duration'} = $info->{'TOTALSAMPLES'}/$info->{'SAMPLERATE'};
print Dumper($info);
return $info;
}
sub SendLocalTrack {
my ($request, $file) = @_;
# fast path, just send the file
my $justsendfile = (!defined($request->{'qs'}{'fmt'})) && (!defined($request->{'qs'}{'max_sample_rate'})) && (!defined($request->{'qs'}{'bitdepth'})) && (!defined($request->{'qs'}{'part'}));
if($justsendfile) {
SendTrack($request, $file);
return;
}
my $evp = $request->{'client'}{'server'}{'evp'};
my $tmpfileloc = $request->{'client'}{'server'}{'settings'}{'MUSIC_TMPDIR'} . '/';
my $nameloc = $request->{'localtrack'}{'nameloc'};
$tmpfileloc .= $nameloc if($nameloc);
my $filebase = $request->{'localtrack'}{'basename'};
# convert to lossy flac if necessary
my $is_flac = lc(substr($file, -5)) eq '.flac';
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, {
'SIGCHLD' => sub {
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]);
my @desired = ([$bitdepth, $max_sample_rate]);
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;
}
push @{$self->{'sources'}}, [$sid, $lib];
OUTER: foreach my $item (@{$lib->[2]}) {
foreach my $already (@wholeLibrary) {
next OUTER if($already->[0] eq $item->[0]);
}
push @wholeLibrary, $item;
}
}
$self->{'library'} = \@wholeLibrary;
$self->LibraryHTML;
return \@wholeLibrary;
}
sub FindInLibrary {
my ($self, $msource, $name) = @_;
my @namearr = split('/', $name);
my $finalstring = $self->{'settings'}{'SOURCES'}{$msource->[0]}{'folder'};
my $lib = $msource->[1];
FindInLibrary_Outer: foreach my $component (@namearr) {
foreach my $libcomponent (@{$lib->[2]}) {
if($libcomponent->[3] eq $component) {
$finalstring .= "/".$libcomponent->[0];
$lib = $libcomponent;
next FindInLibrary_Outer;
}
}
return undef;
}
return {
'node' => $lib,
'path' => $finalstring
};
}
# Define source types here
my %sendFiles = (
'local' => sub {
my ($request, $file, $node, $source, $nameloc) = @_;
return undef if(! -e $file);
if( ! -d $file) {
$request->{'localtrack'} = { 'nameloc' => $nameloc, 'basename' => $node->[0]};
SendLocalTrack($request, $file);
}
else {
$request->SendAsTar($file);
}
return 1;
},
'mhfs' => sub {
my ($request, $file, $node, $source) = @_;
return $request->Proxy($source, $node);
},
'ssh' => sub {
my ($request, $file, $node, $source) = @_;
return $request->SendFromSSH($source, $file, $node);
},
);
sub SendFromLibrary {
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;
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;
my $dname = $node->{'path'};
my $dh;
if(! opendir($dh, $dname)) {
$dname = dirname($node->{'path'});
if(! opendir($dh, $dname)) {
$request->Send404;
return 1;
}
}
# scan dir for art
my @files;
while(my $fname = readdir($dh)) {
my $last = lc(substr($fname, -4));
push @files, $fname if(($last eq '.png') || ($last eq '.jpg') || ($last eq 'jpeg'));
}
closedir($dh);
if( ! @files) {
$request->Send404;
return 1;
}
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) = @_;
# save references to before
my @potentialupdates = ('html', 'musicdbhtml', 'musicdbjson');
my %before;
foreach my $pupdate (@potentialupdates) {
$before{$pupdate} = $self->{$pupdate};
}
# build the new libraries
$self->BuildLibraries();
# determine what needs to be updated
my @updates = (['sources', $self->{'sources'}]);
foreach my $pupdate(@potentialupdates) {
if($before{$pupdate} ne $self->{$pupdate}) {
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__.":";
# no sources until loaded
$self->{'sources'} = [];
$self->{'html'} = __PACKAGE__.' not loaded';
$self->{'musicdbhtml'} = __PACKAGE__.' not loaded';
$self->{'musicdbjson'} = '{}';
my $musicpageroute = sub {
my ($request) = @_;
return $self->SendLibrary($request);
};
my $musicdlroute = sub {
my ($request) = @_;
return $self->SendFromLibrary($request);
};
my $musicresourcesroute = sub {
my ($request) = @_;
return $self->SendResources($request);
};
$self->{'routes'} = [
['/music', $musicpageroute],
['/music_dl', $musicdlroute],
['/music_resources', $musicresourcesroute],
['/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;
}
package MHFS::Plugin::Youtube {
use strict; use warnings;
use feature 'say';
use Data::Dumper;
use feature 'state';
use Encode;
use URI::Escape;
use Scalar::Util qw(looks_like_number weaken);
use File::stat;
MHFS::Util->import();
BEGIN {
if( ! (eval "use JSON; 1")) {
eval "use JSON::PP; 1" or die "No implementation of JSON available";
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
}
}
sub searchbox {
my ($self, $request) = @_;
#my $html = '<form name="searchbox" action="' . $request->{'path'}{'basename'} . '">';
my $html = '<form name="searchbox" action="yt">';
$html .= '<input type="text" width="50%" name="q" ';
my $query = $request->{'qs'}{'q'};
if($query) {
$query =~ s/\+/ /g;
my $escaped = escape_html($query);
$html .= 'value="' . $$escaped . '"';
}
$html .= '>';
if($request->{'qs'}{'media'}) {
$html .= '<input type="hidden" name="media" value="' . $request->{'qs'}{'media'} . '">';
}
$html .= '<input type="submit" value="Search">';
$html .= '</form>';
return $html;
}
sub ytplayer {
my ($self, $request) = @_;
my $html = '<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=no, minimum-scale=1.0, maximum-scale=1.0" /><iframe src="static/250ms_silence.mp3" allow="autoplay" id="audio" style="display:none"></iframe>';
my $url = 'get_video?fmt=yt&id=' . uri_escape($request->{'qs'}{'id'});
$url .= '&media=' . uri_escape($request->{'qs'}{'media'}) if($request->{'qs'}{'media'});
if($request->{'qs'}{'media'} && ($request->{'qs'}{'media'} eq 'music')) {
$request->{'path'}{'basename'} = 'ytaudio';
$html .= '<audio controls autoplay src="' . $url . '">Great Browser</audio>';
}
else {
$request->{'path'}{'basename'} = 'yt';
$html .= '<video controls autoplay src="' . $url . '">Great Browser</video>';
}
return $html;
}
sub sendAsHTML {
my ($self, $request, $response) = @_;
my $json = decode_json($response);
if(! $json){
$request->Send404;
return;
}
my $html = $self->searchbox($request);
$html .= '<div id="vidlist">';
foreach my $item (@{$json->{'items'}}) {
my $id = $item->{'id'}{'videoId'};
next if (! defined $id);
$html .= '<div>';
my $mediaurl = 'ytplayer?fmt=yt&id=' . $id;
my $media = $request->{'qs'}{'media'};
$mediaurl .= '&media=' . uri_escape($media) if(defined $media);
$html .= '<a href="' . $mediaurl . '">' . $item->{'snippet'}{'title'} . '</a>';
$html .= '<br>';
$html .= '<a href="' . $mediaurl . '"><img src="' . $item->{'snippet'}{'thumbnails'}{'default'}{'url'} . '" alt="Excellent image loading"></a>';
$html .= ' <a href="https://youtube.com/channel/' . $item->{'snippet'}{'channelId'} . '">' . $item->{'snippet'}{'channelTitle'} . '</a>';
$html .= '<p>' . $item->{'snippet'}{'description'} . '</p>';
$html .= '<br>-----------------------------------------------';
$html .= '</div>'
}
$html .= '</div>';
$html .= '<script>
var vidlist = document.getElementById("vidlist");
vidlist.addEventListener("click", function(e) {
console.log(e);
let target = e.target.pathname ? e.target : e.target.parentElement;
if(target.pathname && target.pathname.endsWith("ytplayer")) {
e.preventDefault();
console.log(target.href);
let newtarget = target.href.replace("ytplayer", "ytembedplayer");
fetch(newtarget).then( response => response.text()).then(function(data) {
if(data) {
window.history.replaceState(vidlist.innerHTML, null);
window.history.pushState(data, null, target.href);
vidlist.innerHTML = data;
}
});
}
});
window.onpopstate = function(event) {
console.log(event.state);
vidlist.innerHTML = event.state;
}
</script>';
$request->SendHTML($html);
}
sub onYoutube {
my ($self, $request) = @_;
my $evp = $request->{'client'}{'server'}{'evp'};
my $youtubequery = 'q=' . (uri_escape($request->{'qs'}{'q'}) // '') . '&maxResults=' . ($request->{'qs'}{'maxResults'} // '25') . '&part=snippet&key=' . $self->{'settings'}{'Youtube'}{'key'};
$youtubequery .= '&type=video'; # playlists not supported yet
my $tosend = '';
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);
}
},
});
$request->{'process'} = $tprocess;
return -1;
}
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->();
}
});
return 1;
}
sub getOutBase {
my ($self, $qs) = @_;
return undef if(! $qs->{'id'});
my $media;
if(defined $qs->{'media'} && (defined $self->{'fmts'}{$qs->{'media'}})) {
$media = $qs->{'media'};
}
else {
$media = 'video';
}
return $qs->{'id'} . '_' . $media;
}
sub new {
my ($class, $settings, $server) = @_;
my $self = {'settings' => $settings};
bless $self, $class;
$self->{'routes'} = [
['/youtube', sub {
my ($request) = @_;
$self->onYoutube($request);
}],
['/yt', sub {
my ($request) = @_;
$self->onYoutube($request);
}],
['/ytmusic', sub {
my ($request) = @_;
$request->{'qs'}{'media'} //= 'music';
$self->onYoutube($request);
}],
['/ytaudio', sub {
my ($request) = @_;
$request->{'qs'}{'media'} //= 'music';
$self->onYoutube($request);
}],
['/ytplayer', sub {
my ($request) = @_;
my $html = $self->searchbox($request);
$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;
}
package MHFS::Plugin::BitTorrent::Tracker {
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( clock_gettime CLOCK_MONOTONIC);
MHFS::BitTorrent::Bencoding->import();
use Data::Dumper;
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'};
MHFS::BitTorrent::Metainfo::Create($evp, \%maketorrent, sub {
my $torrentData = MHFS::Util::read_file($outputname);
if(!$torrentData) {
$request->Send404;
}
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;
}
})});
}
sub announce_error {
my ($message) = @_;
return ['d', ['bstr', 'failure reason'], ['bstr', $message]];
}
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");
last;
}
my $left = $request->{'qs'}{'left'};
if($left ne unpack('Q', pack('Q', $left))) {
$dictref = announce_error("bad left");
last;
}
if(exists $request->{'qs'}{'compact'} && ($request->{'qs'}{'compact'} eq '0')) {
$dictref = announce_error("Only compact responses supported!");
last;
}
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;
}
}
my $numwant = $request->{'qs'}{'numwant'};
if((! defined $numwant) || ($numwant ne unpack('C', pack('C', $numwant))) || ($numwant > 55)) {
$numwant = 50;
}
my @dict = ('d');
push @dict, ['bstr', 'interval'], ['int', $self->{'announce_interval'}];
my $complete = 0;
my $incomplete = 0;
my $pstr = '';
my $i = 0;
foreach my $peer (keys %{$self->{torrents}{$rih}}) {
if($self->{torrents}{$rih}{$peer}{'completed'}) {
$complete++;
}
else {
$incomplete++;
}
if($i++ < $numwant) {
if($peer ne $ipport) {
my @values = unpack('CCCCCC', $peer);
my $netmap = $request->{'client'}{'server'}{'settings'}{'NETMAP'};
my $pubip = $request->{'client'}{'server'}{'settings'}{'PUBLICIP'};
if($netmap && (($values[0] == $netmap->[1]) && (unpack('C', $ipport) != $netmap->[1])) && $pubip) {
say "HACK converting local peer to public ip";
$peer = pack('Nn', MHFS::Util::ParseIPv4($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'};
# 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 = MHFS::Util::read_file($fullpath);
if(! $torrentcontents) {
say __PACKAGE__.": error reading $fullpath";
return undef;
}
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;
}],
];
return $self;
}
1;
}
package MHFS::Plugin::BitTorrent::Client::Interface {
use strict; use warnings;
use feature 'say';
MHFS::Util->import(qw(escape_html do_multiples get_SI_size));
use URI::Escape qw(uri_escape);
sub is_video {
my ($name) = @_;
my ($ext) = $name =~ /\.(mkv|avi|mp4|webm|flv|ts|mpeg|mpg|m2t|m2ts|wmv)$/i;
return $ext;
}
sub is_mhfs_music_playable {
my ($name) = @_;
return $name =~ /\.(?:flac|mp3|wav)$/i;
}
sub play_in_browser_link {
my ($file, $urlfile) = @_;
return '<a href="video?name=' . $urlfile . '&fmt=hls">HLS (Watch in browser)</a>' if(is_video($file));
return '<a href="music?ptrack=' . $urlfile . '">Play in MHFS Music</a>' if(is_mhfs_music_playable($file));
return 'N/A';
}
sub torrentview {
my ($request) = @_;
my $qs = $request->{'qs'};
my $server = $request->{'client'}{'server'};
my $evp = $server->{'evp'};
# dump out the status, if the torrent's infohash is provided
if(defined $qs->{'infohash'}) {
my $hash = $qs->{'infohash'};
do_multiples({
'bytes_done' => sub { MHFS::BitTorrent::Client::torrent_d_bytes_done($server, $hash, @_); },
'size_bytes' => sub { MHFS::BitTorrent::Client::torrent_d_size_bytes($server, $hash, @_); },
'name' => sub { MHFS::BitTorrent::Client::torrent_d_name($server, $hash, @_); },
}, sub {
if( ! defined $_[0]) { $request->Send404; return;}
my ($data) = @_;
my $torrent_raw = $data->{'name'};
my $bytes_done = $data->{'bytes_done'};
my $size_bytes = $data->{'size_bytes'};
# print out the current torrent status
my $torrent_name = ${escape_html($torrent_raw)};
my $size_print = get_SI_size($size_bytes);
my $done_print = get_SI_size($bytes_done);
my $percent_print = (sprintf "%u%%", ($bytes_done/$size_bytes)*100);
my $buf = '<h1>Torrent</h1>';
$buf .= '<h3><a href="../video">Video</a> | <a href="../music">Music</a></h3>';
$buf .= '<table border="1" >';
$buf .= '<thead><tr><th>Name</th><th>Size</th><th>Done</th><th>Downloaded</th></tr></thead>';
$buf .= "<tbody><tr><td>$torrent_name</td><td>$size_print</td><td>$percent_print</td><td>$done_print</td></tr></tbody>";
$buf .= '</table>';
# Assume we are downloading, if the bytes don't match
if($bytes_done < $size_bytes) {
$buf .= '<meta http-equiv="refresh" content="3">';
$request->SendHTML($buf);
}
else {
# print out the files with usage options
MHFS::BitTorrent::Client::torrent_file_information($server, $qs->{'infohash'}, $torrent_raw, sub {
if(! defined $_[0]){ $request->Send404; return; };
my ($tfi) = @_;
my @files = sort (keys %$tfi);
$buf .= '<br>';
$buf .= '<table border="1" >';
$buf .= '<thead><tr><th>File</th><th>Size</th><th>DL</th><th>Play in browser</th></tr></thead>';
$buf .= '<tbody';
foreach my $file (@files) {
my $htmlfile = ${escape_html($file)};
my $urlfile = uri_escape($file);
my $link = '<a href="get_video?name=' . $urlfile . '&fmt=noconv">DL</a>';
my $playlink = play_in_browser_link($file, $urlfile);
$buf .= "<tr><td>$htmlfile</td><td>" . get_SI_size($tfi->{$file}{'size'}) . "</td><td>$link</td>";
$buf .= "<td>$playlink</td>" if(!defined($qs->{'playinbrowser'}) || ($qs->{'playinbrowser'} == 1));
$buf .= "</tr>";
}
$buf .= '</tbody';
$buf .= '</table>';
$request->SendHTML($buf);
});
}
});
}
else {
MHFS::BitTorrent::Client::torrent_list_torrents($server, sub{
if(! defined $_[0]){ $request->Send404; return; };
my ($rtresponse) = @_;
my @lines = split( /\n/, $rtresponse);
my $buf = '<h1>Torrents</h1>';
$buf .= '<h3><a href="video?action=browsemovies">Browse Movies</a> | <a href="video">Video</a> | <a href="music">Music</a></h3>';
$buf .= '<table border="1" >';
$buf .= '<thead><tr><th>Name</th><th>Hash</th><th>Size</th><th>Done</th><th>Private</th></tr></thead>';
$buf .= "<tbody>";
my $curtor = '';
while(1) {
if($curtor =~ /^\[(u?)['"](.+)['"],\s'(.+)',\s([0-9]+),\s([0-9]+),\s([0-9]+)\]$/) {
my %torrent;
my $is_unicode = $1;
$torrent{'name'} = $2;
$torrent{'hash'} = $3;
$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;
}
$curtor .= $line;
}
}
$buf .= '</tbody></table>';
$request->SendHTML($buf);
});
}
}
sub torrentload {
my ($request) = @_;
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;
}
});
});
return;
}
}
$request->Send404;
}
sub new {
my ($class, $settings) = @_;
my $self = { 'dlsubsystems' => {}};
bless $self, $class;
$self->{'routes'} = [
[ '/torrent/view', \&torrentview ],
[ '/torrent/load', \&torrentload ]
];
return $self;
}
1;
}
package MHFS::Plugin::OpenDirectory {
use strict; use warnings;
use feature 'say';
sub new {
my ($class, $settings) = @_;
my $self = {};
bless $self, $class;
my $odmappings = $settings->{OPENDIRECTORY}{maps};
$self->{'routes'} = [
[
'/od', sub {
my ($request) = @_;
$request->SendRedirect(301, 'od/');
}
],
[
'/od/*', sub {
my ($request) = @_;
foreach my $key (keys %{$odmappings}) {
if(rindex($request->{'path'}{'unsafepath'}, '/od/'.$key, 0) == 0) {
$request->SendDirectoryListing($odmappings->{$key}, '/od/'.$key);
return;
}
}
$request->Send404;
}
],
];
return $self;
}
1;
}
package MHFS::Plugin::Playlist {
use strict; use warnings;
use feature 'say';
use Data::Dumper;
use URI::Escape qw(uri_escape);
use Encode qw(decode);
sub video_get_m3u8 {
my ($video, $urlstart) = @_;
my $buf;
my $m3u8 = <<'M3U8END';
#EXTM3U
#EXTVLCOPT:network-caching=40000'
M3U8END
my @files;
if(! -d $video->{'src_file'}{'filepath'}) {
push @files, $video->{'src_file'}{'fullname'};
}
else {
output_dir_versatile($video->{'src_file'}{'filepath'}, {
'root' => $video->{'src_file'}{'root'},
'on_file' => sub {
my ($path, $shortpath) = @_;
push @files, $shortpath;
}
});
}
foreach my $file (@files) {
$m3u8 .= '#EXTINF:0, ' . decode('UTF-8', $file, Encode::LEAVE_SRC) . "\n";
$m3u8 .= $urlstart . uri_escape($file) . "\n";
#$m3u8 .= $urlstart . small_url_encode($file) . "\n";
}
return \$m3u8;
}
sub new {
my ($class, $settings, $server) = @_;
my $self = {};
bless $self, $class;
my @subsystems = ('video');
$self->{'routes'} = [
[
'/playlist/*', sub {
my ($request) = @_;
my $qs = $request->{'qs'};
my @pathcomponents = split('/', $request->{'path'}{'unsafepath'});
if(scalar(@pathcomponents) >= 3) {
if($pathcomponents[2] eq 'video') {
if(scalar(@pathcomponents) >= 5) {
my %video = ('out_fmt' => ($request->{'qs'}{'vfmt'} // 'noconv'));
my $sid = $pathcomponents[3];
splice(@pathcomponents, 0, 4);
my $nametolookup = join('/', @pathcomponents);
$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;
}
}
}
}
$request->Send404;
}
],
];
return $self;
}
1;
}
package MHFS::Plugin::Kodi::Movies {
use strict; use warnings;
sub TO_JSON {
my ($self) = @_;
{movies => MHFS::Plugin::Kodi::_format_movies($self->{movies})}
}
sub TO_HTML {
my ($self) = @_;
my $movies = $self->TO_JSON()->{movies};
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
foreach my $movie (@$movies) {
$buf .= MHFS::Plugin::Kodi::_html_list_item($movie->{id}, 1);
}
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi::Movie {
use strict; use warnings;
sub TO_JSON {
my ($self) = @_;
my %movie = %{$self->{movie}};
$movie{editions} = MHFS::Plugin::Kodi::_format_movie_editions($movie{editions});
{movie => \%movie}
}
sub TO_HTML {
my ($self) = @_;
my $editions = $self->TO_JSON()->{movie}{editions};
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
foreach my $edition (@$editions) {
$buf .= MHFS::Plugin::Kodi::_html_list_item($edition->{id}, 1, $edition->{name});
}
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi::MovieEditions {
use strict; use warnings;
sub TO_JSON {
my ($self) = @_;
{editions => MHFS::Plugin::Kodi::_format_movie_editions($self->{editions})}
}
sub TO_HTML {
my ($self) = @_;
my $editions = $self->TO_JSON()->{editions};
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
foreach my $edition (@$editions) {
$buf .= MHFS::Plugin::Kodi::_html_list_item("../".$edition->{id}, 1, $edition->{name});
}
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi::MovieEdition {
use strict; use warnings;
sub TO_JSON {
my ($self) = @_;
{edition => MHFS::Plugin::Kodi::_format_movie_edition($self->{source}, $self->{editionname}, $self->{edition})}
}
sub TO_HTML {
my ($self) = @_;
my $parts = $self->TO_JSON()->{edition}{parts};
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
foreach my $part (@$parts) {
$buf .= MHFS::Plugin::Kodi::_html_list_item($part->{id}, 1, $part->{name});
}
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi::MoviePart {
use strict; use warnings;
use File::Basename qw(basename);
sub TO_JSON {
my ($self) = @_;
{part => MHFS::Plugin::Kodi::_format_movie_part($self->{editionname}, $self->{partname}, $self->{part})}
}
sub TO_HTML {
my ($self) = @_;
my $part = $self->TO_JSON()->{part};
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
$buf .= MHFS::Plugin::Kodi::_html_list_item("../".$part->{id}, 0, $part->{name});
if (exists $part->{subs}) {
foreach my $sub (@{$part->{subs}}) {
$buf .= MHFS::Plugin::Kodi::_html_list_item($sub, 0, basename($sub));
}
}
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi::MovieSubtitle {
use strict; use warnings;
use File::Basename qw(basename);
sub TO_JSON {
my ($self) = @_;
{subtitle => $self->{subtitle}}
}
sub TO_HTML {
my ($self) = @_;
my $buf = '<style>ul{list-style: none;} li{margin: 10px 0;}</style><ul>';
my $subname = basename($self->{subtitle});
$buf .= MHFS::Plugin::Kodi::_html_list_item("../$subname", 0, $subname);
$buf .= '</ul>';
$buf
}
1;
}
package MHFS::Plugin::Kodi {
use strict; use warnings;
use feature 'say';
use File::Basename qw(basename);
use Cwd qw(abs_path getcwd);
use URI::Escape qw(uri_escape);
use Encode qw(decode encode);
use File::Path qw(make_path);
use Data::Dumper qw(Dumper);
use Scalar::Util qw(weaken);
use MIME::Base64 qw(encode_base64url decode_base64url);
use Devel::Peek qw(Dump);
MHFS::Util->import(qw(decode_UTF_8 encode_UTF_8 base64url_to_str str_to_base64url uri_escape_path_utf8));
BEGIN {
if( ! (eval "use JSON; 1")) {
eval "use JSON::PP; 1" or die "No implementation of JSON available";
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
}
}
# format tv library for kodi http
sub route_tv {
my ($self, $request, $absdir, $kodidir) = @_;
# read in the shows
my $tvdir = abs_path($absdir);
if(! defined $tvdir) {
$request->Send404;
return;
}
my $dh;
if(! opendir ( $dh, $tvdir )) {
warn "Error in opening dir $tvdir\n";
$request->Send404;
return;
}
my %shows = ();
my @diritems;
while( (my $filename = readdir($dh))) {
next if(($filename eq '.') || ($filename eq '..'));
next if(!(-s "$tvdir/$filename"));
# extract the showname
next if($filename !~ /^(.+)[\.\s]+S\d+/);
my $showname = $1;
if($showname) {
$showname =~ s/\./ /g;
if(! $shows{$showname}) {
$shows{$showname} = [];
my %diritem = ('item' => $showname, 'isdir' => 1);
my $plot = $self->{tvmeta}."/$showname/plot.txt";
if(-f $plot) {
my $plotcontents = MHFS::Util::read_file($plot);
$diritem{plot} = $plotcontents;
}
push @diritems, \%diritem;
}
push @{$shows{$showname}}, "$tvdir/$filename";
}
}
closedir($dh);
# locate the content
if($request->{'path'}{'unsafepath'} ne $kodidir) {
my $fullshowname = substr($request->{'path'}{'unsafepath'}, length($kodidir)+1);
my $slash = index($fullshowname, '/');
@diritems = ();
my $showname = ($slash != -1) ? substr($fullshowname, 0, $slash) : $fullshowname;
my $showfilename = ($slash != -1) ? substr($fullshowname, $slash+1) : undef;
my $showitems = $shows{$showname};
if(!$showitems) {
$request->Send404;
return;
}
my @initems = @{$showitems};
my @outitems;
# TODO replace basename usage?
while(@initems) {
my $item = shift @initems;
$item = abs_path($item);
if(! $item) {
say "bad item";
}
elsif(rindex($item, $tvdir, 0) != 0) {
say "bad item, path traversal?";
}
elsif(-f $item) {
my $filebasename = basename($item);
if(!$showfilename) {
push @diritems, {'item' => $filebasename, 'isdir' => 0};
}
elsif($showfilename eq $filebasename) {
if(index($request->{'path'}{'unsafecollapse'}, '/', length($request->{'path'}{'unsafecollapse'})-1) == -1) {
say "found show filename";
$request->SendFile($item);
}
else {
$request->Send404;
}
return;
}
}
elsif(-d _) {
opendir(my $dh, $item) or die('failed to open dir');
my @newitems;
while(my $newitem = readdir($dh)) {
next if(($newitem eq '.') || ($newitem eq '..'));
push @newitems, "$item/$newitem";
}
closedir($dh);
unshift @initems, @newitems;
}
else {
say "bad item unknown filetype " . $item;
}
}
}
# redirect if the slash wasn't there
if(index($request->{'path'}{'unescapepath'}, '/', length($request->{'path'}{'unescapepath'})-1) == -1) {
$request->SendRedirect(301, substr($request->{'path'}{'unescapepath'}, rindex($request->{'path'}{'unescapepath'}, '/')+1).'/');
return;
}
# generate the directory html
if(exists $request->{qs}{fmt} && $request->{qs}{fmt} eq 'html') {
my $buf = '';
foreach my $show (@diritems) {
my $showname = $show->{'item'};
my $url = uri_escape($showname);
$url .= '/' if($show->{'isdir'});
$buf .= '<a href="' . $url .'">'.${MHFS::Util::escape_html_noquote(decode('UTF-8', $showname, Encode::LEAVE_SRC))} .'</a><br><br>';
}
$request->SendHTML($buf);
} else {
$request->SendAsJSON(\@diritems);
}
}
sub readsubdir{
my ($subtitles, $source, $b_path) = @_;
opendir( my $dh, $b_path ) or return;
while(my $b_filename = readdir($dh)) {
next if(($b_filename eq '.') || ($b_filename eq '..'));
my $filename = decode_UTF_8($b_filename) or do {
warn "$b_filename is not, UTF-8, skipping";
next;
};
my $b_nextpath = "$b_path/$b_filename";
my $nextsource = "$source/$filename";
if(-f $b_nextpath && $filename =~ /\.(?:srt|sub|idx)$/) {
push @$subtitles, $nextsource;
next;
} elsif (-d _) {
readsubdir($subtitles, $nextsource, $b_nextpath);
}
}
}
sub readmoviedir {
my ($self, $movies, $source, $b_moviedir) = @_;
opendir(my $dh, $b_moviedir ) or do {
warn "Error in opening dir $b_moviedir\n";
return undef;
};
while(my $b_edition = readdir($dh)) {
next if(($b_edition eq '.') || ($b_edition eq '..'));
my $edition = decode_UTF_8($b_edition) or do {
warn "$b_edition is not, UTF-8, skipping";
next;
};
# recurse on collections
if ($edition =~ /(?:Duology|Trilogy|Quadrilogy)/) {
next if ($edition =~ /\.nfo$/);
$self->readmoviedir($movies, "$source/$edition", "$b_moviedir/$b_edition");
next;
}
-s "$b_moviedir/$b_edition" or next;
my $isdir = -d _;
$isdir || -f _ or next;
$isdir ||= 0;
my %edition;
if (!$isdir) {
if ($edition !~ /\.(?:avi|mkv|mp4|m4v)$/) {
warn "Skipping $edition, not a movie file" if ($edition !~ /\.(?:txt)$/);
next;
}
$edition{''} = {};
} else {
my $b_path = "$b_moviedir/$b_edition";
my @videos;
my @subtitles;
my @subtitledirs;
opendir(my $dh, $b_path) or die('failed to open dir');
while(my $b_editionitem = readdir($dh)) {
next if(($b_editionitem eq '.') || ($b_editionitem eq '..'));
my $editionitem = decode_UTF_8($b_editionitem) or do {
warn "$b_editionitem is not, UTF-8, skipping";
next;
};
my $type;
if ($b_editionitem =~ /\.(?:avi|mkv|mp4|m4v)$/) {
$type = 'video' if ($b_editionitem !~ /sample(?:\-[a-z]+)?\.(?:avi|mkv|mp4)$/);
} elsif ($b_editionitem =~ /\.(?:srt|sub|idx)$/) {
$type = 'subtitle';
} elsif ($b_editionitem =~ /^Subs$/i) {
$type = 'subtitledir';
}
$type or next;
if (-f "$b_path/$b_editionitem") {
push @videos, $editionitem if($type eq 'video');
push @subtitles, $editionitem if($type eq 'subtitle');
} elsif (-d _ && $type eq 'subtitledir') {
push @subtitledirs, $editionitem;
}
}
closedir($dh);
if (!@videos) {
warn "not adding edition $edition, no videos found";
next;
}
foreach my $subdir (@subtitledirs) {
readsubdir(\@subtitles, $subdir, "$b_path/$subdir");
}
foreach my $videofile (@videos) {
my ($withoutext) = $videofile =~ /^(.+)\.[^\.]+$/;
my %relevantsubs;
for my $i (reverse 0 .. $#subtitles) {
if (basename($subtitles[$i]) =~ /^\Q$withoutext\E/i) {
$relevantsubs{splice(@subtitles, $i, 1)} = undef;
}
}
$edition{"/$videofile"} = scalar %relevantsubs ? {subs => \%relevantsubs} : {};
}
if(@subtitles) {
warn "$edition: unmatched subtitle $_" foreach @subtitles;
}
}
my $showname;
my $withoutyear;
my $year;
if($edition =~ /^(.+)[\.\s]+\(?(\d{4})([^p]|$)/) {
$showname = "$1 ($2)";
$withoutyear = $1;
$year = $2;
$withoutyear =~ s/\./ /g;
}
elsif ($edition =~ /(.+)\s?\[(\d{4})\]/) {
$showname = "$1 ($2)";
$withoutyear = $1;
$year = $2;
$withoutyear =~ s/\./ /g;
}
elsif($edition =~ /^(.+)[\.\s](?i:DVDRip)[\.\s]./) {
$showname = $1;
}
elsif($edition =~ /^(.+)[\.\s](?:DVD|RERIP|BRrip)/) {
$showname = $1;
}
elsif($edition =~ /^(.+)\s\(PSP.+\)/) {
$showname = $1;
}
elsif($edition =~ /^(.+)\.VHS/) {
$showname = $1;
}
elsif($edition =~ /^(.+)[\.\s]+\d{3,4}p\./) {
$showname = $1;
}
elsif($edition =~ /^(.+)\.[a-zA-Z\d]{3,4}$/) {
$showname = $1;
}
else{
$showname = $edition;
}
$showname =~ s/\./ /g;
if(! $movies->{$showname}) {
my %diritem;
if(defined $year) {
$diritem{name} = $withoutyear;
$diritem{year} = $year;
}
if (my $b_showname = encode_UTF_8($showname)) {
my $plot = $self->{moviemeta}."/$b_showname/plot.txt";
if(-f $plot) {
my $plotcontents = MHFS::Util::read_file($plot);
$diritem{plot} = $plotcontents;
}
} else {
warn "$showname is not UTF-8, not reading plot";
}
$movies->{$showname} = \%diritem;
}
$movies->{$showname}{editions}{"$source/$edition"} = \%edition;
}
closedir($dh);
}
sub _build_movie_library {
my ($self, $sources) = @_;
my %movies;
foreach my $source (@$sources) {
if ($self->{server}{settings}{SOURCES}{$source}{type} ne 'local') {
warn "skipping source $source, only local implemented";
next;
}
my $b_moviedir = $self->{server}{settings}{SOURCES}{$source}{folder};
$self->readmoviedir(\%movies, $source, $b_moviedir);
}
\%movies
}
# returns undef on not found
sub _search_movie_library {
my ($self, $movies, $movieid, $source, $editionname, $partname, $subfile) = @_;
unless(exists $movies->{$movieid}) {
warn "movie not found";
return undef;
}
$movies = $movies->{$movieid};
if (!$source) {
return bless {movie => $movies}, 'MHFS::Plugin::Kodi::Movie';
}
$movies = $movies->{editions};
if(!$editionname) {
my %editions = map { $_ =~ /^$source/ ? ($_ => $movies->{$_}) : () } keys %$movies;
return bless {editions => \%editions}, 'MHFS::Plugin::Kodi::MovieEditions';
}
unless(exists $movies->{"$source/$editionname"}) {
warn "movie source not found";
return undef;
}
$movies = $movies->{"$source/$editionname"};
unless(defined $partname) {
return bless {source => $source, editionname => $editionname, edition => $movies}, 'MHFS::Plugin::Kodi::MovieEdition';
}
unless(exists $movies->{$partname}) {
warn "movie part not found";
return undef;
}
my $b_moviedir = $self->{server}{settings}{SOURCES}{$source}{folder};
my $b_editionname = encode_UTF_8($editionname) or do {
warn "$editionname is not UTF-8";
return undef;
};
my $b_editiondir = "$b_moviedir/$b_editionname";
$movies = $movies->{$partname};
if (!$subfile) {
my $b_partname = encode_UTF_8($partname) // do {
warn "$partname is not UTF-8";
return undef;
};
return bless {b_path => "$b_editiondir$b_partname", editionname => $editionname, partname => $partname, part => $movies}, 'MHFS::Plugin::Kodi::MoviePart';
}
unless(exists $movies->{subs} && exists $movies->{subs}{$subfile}) {
warn "subtitle file not found";
return undef;
}
my $b_subfile = encode_UTF_8($subfile) or do {
warn "$subfile is not UTF-8";
return undef;
};
return bless {b_path => "$b_editiondir/$b_subfile", subtitle => $subfile}, 'MHFS::Plugin::Kodi::MovieSubtitle';
}
sub _format_movie_subs {
my ($subs) = @_;
my @subs = map {
# kodi needs a basename with a parsable extension
my ($loc, $filename) = $_ =~ /^(.+\/|)([^\/]+)$/;
$loc = str_to_base64url($loc);
"$loc-sb/$filename"
} keys %$subs;
\@subs
}
sub _format_movie_part {
my ($editionname, $name, $paart) = @_;
my $b64_name = str_to_base64url($name);
my %part = (
id => "$b64_name-pt",
name => basename("$editionname$name")
);
if (exists $paart->{subs}) {
$part{subs} = _format_movie_subs($paart->{subs});
}
\%part
}
sub _format_movie_edition {
my ($sourcename, $editionname, $ediition) = @_;
my @sortedkeys = sort {basename($a) cmp basename($b)} keys %$ediition;
my @parts = map {
_format_movie_part($editionname, $_, $ediition->{$_})
} @sortedkeys;
my $editionid = "$sourcename/".str_to_base64url($editionname);
my %edition = ( id => $editionid, name => basename($editionname), parts => \@parts);
\%edition
}
# transform $diritems{movie}{editions}{source/name}{|parts}
# to $diritems{movie}{editions}[{name, parts}]
sub _format_movie_editions {
my ($ediitions) = @_;
my @sortedkeys = sort {basename($a) cmp basename($b)} keys %$ediitions;
my @editions = map {
my ($sourcename, $editionname) = split('/', $_, 2);
_format_movie_edition($sourcename, $editionname, $ediitions->{$_})
} @sortedkeys;
\@editions
}
sub _format_movies {
my ($moovies) = @_;
my @sortedkeys = sort {basename($a) cmp basename($b)} keys %$moovies;
my @movies = map {
my %movie = %{$moovies->{$_}};
$movie{id} = $_;
$movie{editions} = _format_movie_editions($movie{editions});
\%movie
} @sortedkeys;
\@movies
}
sub _html_list_item {
my ($item, $isdir, $label) = @_;
$label //= $item;
my $url = uri_escape_path_utf8($item);
$url .= '/?fmt=html' if($isdir);
'<li><a href="' . $url .'">'. ${MHFS::Util::escape_html_noquote($label)} .'</a></li>'
}
# format movies library for kodi http
sub route_movies {
my ($self, $request, $sources, $kodidir) = @_;
my $request_path = decode_UTF_8($request->{path}{unsafepath}) or do {
warn "$request->{path}{unsafepath} is not, UTF-8, 404";
$request->Send404;
return;
};
# build the movie library
if(! exists $self->{movies} || $request_path eq $kodidir) {
$self->{movies} = $self->_build_movie_library($sources);
}
my $movies = $self->{movies};
unless ($movies) {
$request->Send404;
return;
}
# 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;
if ($source) {
say "source $source";
if ($b64_editionname) {
$editionname = base64url_to_str($b64_editionname) or do {
warn "$b64_editionname does not decode to a valid string";
$request->Send404;
return;
};
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) // do {
warn "$b64_partname does not decode to a valid string";;
$request->Send404;
return;
};
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) // do {
warn "$b64_subpath does not decode to a valid string";
$request->Send404;
return;
};
$subfile = "$subpath$subname";
say "subfile $subfile";
}
}
}
}
$movieitem = $self->_search_movie_library($movies, $movieid, $source, $editionname, $partname, $subfile);
if (!$movieitem) {
$request->Send404;
return;
}
elsif (substr($request->{'path'}{'unescapepath'}, -1) ne '/') {
# redirect if we aren't accessing a file
if (!exists $movieitem->{b_path}) {
$request->SendRedirect(301, substr($request->{'path'}{'unescapepath'}, rindex($request->{'path'}{'unescapepath'}, '/')+1).'/');
} else {
$request->SendFile($movieitem->{b_path});
}
return;
}
} else {
$movieitem = bless {movies => $movies}, 'MHFS::Plugin::Kodi::Movies';
}
# render
if(exists $request->{qs}{fmt} && $request->{qs}{fmt} eq 'html') {
my $buf = $movieitem->TO_HTML;
$request->SendHTML($buf);
} else {
my $diritems = $movieitem->TO_JSON;
$request->SendAsJSON($diritems);
}
}
sub route_kodi {
my ($self, $request, $kodidir) = @_;
my $request_path = decode_UTF_8($request->{path}{unsafepath}) or do {
warn "$request->{path}{unsafepath} is not, UTF-8, 404";
$request->Send404;
return;
};
my $baseurl = $request->getAbsoluteURL;
my $repo_addon_version = '0.1.0';
my $repo_addon_name = "repository.mhfs-$repo_addon_version.zip";
if ($request_path eq $kodidir) {
my $html = <<"END_HTML";
<style>ul{list-style: none;} li{margin: 10px 0;}</style>
<h1>MHFS Kodi Setup Instructions</h1>
<ol>
<li>Open Kodi</li>
<li>Go to <b>Settings->File manager</b>, <b>Add source</b> (you may have to double-click), and add <b>$baseurl$kodidir</b> (the URL of this page) as a source.</li>
<li>Go to <b>Settings->Add-ons->Install from zip file</b>, open the source you just added, and select <b>$repo_addon_name</b>. The repository add-on should install.</li>
<li>From <b>Settings->Add-ons</b> (you should still be on that page), <b>Install from repository->MHFS Repository->Video add-ons->MHFS Video</b> and click <b>Install</b>. The plugin addon should install.</li>
<li>Click <b>Configure</b> (or open the MHFS Video settings) and fill in <b>$baseurl</b> (the URL of the MHFS server you want to connect to).</li>
<li>MHFS Video should now be installed, you should be able to access it from <b>Add-ons->Video add-ons->MHFS Video</b> on the main menu</li>
</ol>
<ul>
<a href="$repo_addon_name">$repo_addon_name</a>
</ul>
END_HTML
$request->SendHTML($html);
return;
} elsif (substr($request_path, length($kodidir)+1) ne $repo_addon_name ||
substr($request->{'path'}{'unescapepath'}, -1) eq '/') {
$request->Send404;
return;
}
my $xml = <<"END_XML";
<?xml version="1.0" encoding="UTF-8"?>
<addon id="repository.mhfs"
name="MHFS Repository"
version="$repo_addon_name"
provider-name="G4Vi">
<extension point="xbmc.addon.repository" name="MHFS Repository">
<dir>
<info>$baseurl/static/kodi/addons.xml</info>
<checksum>$baseurl/static/kodi/addons.xml.md5</checksum>
<datadir zip="true">$baseurl/static/kodi</datadir>
</dir>
</extension>
<extension point="xbmc.addon.metadata">
<summary lang="en_GB">MHFS Repository</summary>
<description lang="en_GB">TODO</description>
<disclaimer></disclaimer>
<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";
$request->Send404;
return;
};
_zip_Promise($request->{client}{server}, $tmpdir, ['repository.mhfs'])->then(sub {
$request->SendBytes('application/zip', $_[0]);
}, sub {
warn $_[0];
$request->Send404;
});
}
sub _zip {
my ($server, $start_in, $params, $on_success, $on_failure) = @_;
MHFS::Process->new_output_child($server->{evp}, sub {
# done in child
my ($datachannel) = @_;
chdir($start_in);
open(STDOUT, ">&", $datachannel) or die("Can't dup \$datachannel to STDOUT");
exec('zip', '-r', '-', @$params);
#exec('zip', '-r', 'repository.mhfs.zip', 'repository.mhfs');
die "failed to run zip";
}, sub {
my ($out, $err, $status) = @_;
if ($status != 0) {
$on_failure->('failed to zip');
return;
}
$on_success->($out);
}) // $on_failure->('failed to fork');
}
sub _zip_Promise {
my ($server, $start_in, $params) = @_;
return MHFS::Promise->new($server->{evp}, sub {
my ($resolve, $reject) = @_;
_zip($server, $start_in, $params, sub {
$resolve->($_[0]);
}, sub {
$reject->($_[0]);
});
});
}
sub _curl {
my ($server, $params, $cb) = @_;
my $process;
my @cmd = ('curl', @$params);
print "$_ " foreach @cmd;
print "\n";
$process = MHFS::Process->new_io_process($server->{evp}, \@cmd, sub {
my ($output, $error) = @_;
$cb->($output);
});
if(! $process) {
$cb->(undef);
}
return $process;
}
sub _TMDB_api {
my ($server, $route, $qs, $cb) = @_;
my $url = 'https://api.themoviedb.org/3/' . $route;
$url .= '?api_key=' . $server->{settings}{TMDB} . '&';
if($qs){
foreach my $key (keys %{$qs}) {
my @values;
if(ref($qs->{$key}) ne 'ARRAY') {
push @values, $qs->{$key};
}
else {
@values = @{$qs->{$key}};
}
foreach my $value (@values) {
$url .= uri_escape($key).'='.uri_escape($value) . '&';
}
}
}
chop $url;
return _curl($server, [$url], sub {
$cb->(decode_json($_[0]));
});
}
sub _TMDB_api_promise {
my ($server, $route, $qs) = @_;
return MHFS::Promise->new($server->{evp}, sub {
my ($resolve, $reject) = @_;
_TMDB_api($server, $route, $qs, sub {
$resolve->($_[0]);
});
});
}
sub _DownloadFile {
my ($server, $url, $dest, $cb) = @_;
return _curl($server, ['-k', $url, '-o', $dest], $cb);
}
sub _DownloadFile_promise {
my ($server, $url, $dest) = @_;
return MHFS::Promise->new($server->{evp}, sub {
my ($resolve, $reject) = @_;
_DownloadFile($server, $url, $dest, sub {
$resolve->();
});
});
}
sub DirectoryRoute {
my ($path_without_end_slash, $cb) = @_;
return ([
$path_without_end_slash, sub {
my ($request) = @_;
$request->SendRedirect(301, substr($path_without_end_slash, rindex($path_without_end_slash, '/')+1).'/');
}
], [
"$path_without_end_slash/*", $cb
]);
}
sub route_metadata {
my ($self, $request) = @_;
while(1) {
if($request->{'path'}{'unsafepath'} !~ m!^/kodi/metadata/(movies|tv)/(thumb|fanart|plot)/(.+)$!) {
last;
}
my ($mediatype, $metadatatype, $medianame) = ($1, $2, $3);
say "mt $mediatype mmt $metadatatype mn $medianame";
my %allmediaparams = ( 'movies' => {
'meta' => $self->{moviemeta},
'search' => 'movie',
}, 'tv' => {
'meta' => $self->{tvmeta},
'search' => 'tv'
});
my $params = $allmediaparams{$mediatype};
if(index($medianame, '/') != -1 || $medianame =~ /^.(.)?$/) {
last;
}
my $metadir = $params->{meta} . '/' . $medianame;
# fast path, exists on disk
if (-d $metadir) {
my %acceptable = ( 'thumb' => ['png', 'jpg'], 'fanart' => ['png', 'jpg'], 'plot' => ['txt']);
if(exists $acceptable{$metadatatype}) {
foreach my $totry (@{$acceptable{$metadatatype}}) {
my $path = $metadir.'/'.$metadatatype.".$totry";
if(-f $path) {
$request->SendLocalFile($path);
return;
}
}
}
}
# slow path, download it
$request->{client}{server}{settings}{TMDB} or last;
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 {
if($metadatatype eq 'plot' || ! -f "$metadir/plot.txt") {
make_path($metadir);
MHFS::Util::write_file("$metadir/plot.txt", $_[0]->{results}[0]{overview});
}
if($metadatatype eq 'plot') {
$request->SendLocalFile("$metadir/plot.txt");
return;
}
# thumb or fanart
my $imagepartial = ($metadatatype eq 'thumb') ? $_[0]->{results}[0]{poster_path} : $_[0]->{results}[0]{backdrop_path};
if (!$imagepartial || $imagepartial !~ /(\.[^\.]+)$/) {
return MHFS::Promise::throw('path not matched');
}
my $ext = $1;
make_path($metadir);
return MHFS::Promise->new($request->{client}{server}{evp}, sub {
my ($resolve, $reject) = @_;
if(! defined $self->{tmdbconfig}) {
$resolve->(_TMDB_api_promise($request->{client}{server}, 'configuration')->then( sub {
$self->{tmdbconfig} = $_[0];
return $_[0];
}));
} else {
$resolve->();
}
})->then( sub {
return _DownloadFile_promise($request->{client}{server}, $self->{tmdbconfig}{images}{secure_base_url}.'original'.$imagepartial, "$metadir/$metadatatype$ext")->then(sub {
$request->SendLocalFile("$metadir/$metadatatype$ext");
return;
});
});
})->then(undef, sub {
say $_[0];
$request->Send404;
return;
});
return;
}
$request->Send404;
}
sub new {
my ($class, $settings) = @_;
my $self = {};
bless $self, $class;
my @subsystems = ('video');
$self->{moviemeta} = $settings->{'DATADIR'}.'/movies';
$self->{tvmeta} = $settings->{'DATADIR'}.'/tv';
make_path($self->{moviemeta}, $self->{tvmeta});
$self->{'routes'} = [
DirectoryRoute('/kodi/movies', sub {
my ($request) = @_;
route_movies($self, $request, $settings->{'MEDIASOURCES'}{'movies'}, '/kodi/movies');
}),
DirectoryRoute('/kodi/tv', sub {
my ($request) = @_;
route_tv($self, $request, $settings->{'MEDIALIBRARIES'}{'tv'}, '/kodi/tv');
}),
['/kodi/metadata/*', sub {
my ($request) = @_;
route_metadata($self, $request);
}],
DirectoryRoute('/kodi', sub {
my ($request) = @_;
route_kodi($self, $request, '/kodi');
}),
];
return $self;
}
1;
}
package MHFS::Plugin::GetVideo {
use strict; use warnings;
use feature 'say';
use Data::Dumper qw (Dumper);
use Fcntl qw(:seek);
use Scalar::Util qw(weaken);
use URI::Escape qw (uri_escape);
use Devel::Peek qw(Dump);
no warnings "portable";
use Config;
MHFS::Util->import();
sub new {
my ($class, $settings) = @_;
if($Config{ivsize} < 8) {
warn("Integers are too small!");
return undef;
}
my $self = {};
bless $self, $class;
$self->{'VIDEOFORMATS'} = {
'hls' => {'lock' => 0, 'create_cmd' => sub {
my ($video) = @_;
return ['ffmpeg', '-i', $video->{"src_file"}{"filepath"}, '-codec:v', 'libx264', '-strict', 'experimental', '-codec:a', 'aac', '-ac', '2', '-f', 'hls', '-hls_base_url', $video->{"out_location_url"}, '-hls_time', '5', '-hls_list_size', '0', '-hls_segment_filename', $video->{"out_location"} . "/" . $video->{"out_base"} . "%04d.ts", '-master_pl_name', $video->{"out_base"} . ".m3u8", $video->{"out_filepath"} . "_v"]
}, 'ext' => 'm3u8', 'desired_audio' => 'aac',
'player_html' => $settings->{'DOCUMENTROOT'} . '/static/hls_player.html'},
'jsmpeg' => {'lock' => 0, 'create_cmd' => sub {
my ($video) = @_;
return ['ffmpeg', '-i', $video->{"src_file"}{"filepath"}, '-f', 'mpegts', '-codec:v', 'mpeg1video', '-codec:a', 'mp2', '-b', '0', $video->{"out_filepath"}];
}, 'ext' => 'ts', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/jsmpeg_player.html', 'minsize' => '1048576'},
'mp4' => {'lock' => 1, 'create_cmd' => sub {
my ($video) = @_;
return ['ffmpeg', '-i', $video->{"src_file"}{"filepath"}, '-c:v', 'copy', '-c:a', 'aac', '-f', 'mp4', '-movflags', 'frag_keyframe+empty_moov', $video->{"out_filepath"}];
}, 'ext' => 'mp4', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/mp4_player.html', 'minsize' => '1048576'},
'noconv' => {'lock' => 0, 'ext' => '', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/noconv_player.html', },
'mkvinfo' => {'lock' => 0, 'ext' => ''},
'fmp4' => {'lock' => 0, 'ext' => ''},
};
$self->{'routes'} = [
[
'/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'})) {
if(defined($qs->{'sid'})) {
$video{'src_file'} = $server->{'fs'}->lookup($qs->{'name'}, $qs->{'sid'});
if( ! $video{'src_file'} ) {
$request->Send404;
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;
}
if(! -e $video{'src_file'}{'filepath'}) {
$request->Send404;
return undef;
}
$video{'out_base'} = $video{'src_file'}{'name'};
# soon https://github.com/video-dev/hls.js/pull/1899
$video{'out_base'} = space2us($video{'out_base'}) if ($video{'out_fmt'} eq 'hls');
}
elsif($videoformats->{$video{'out_fmt'}}{'plugin'}) {
$video{'plugin'} = $videoformats->{$video{'out_fmt'}}{'plugin'};
if(!($video{'out_base'} = $video{'plugin'}->getOutBase($qs))) {
$request->Send404;
return undef;
}
}
else {
$request->Send404;
return undef;
}
# 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)) {
# hack for jsmpeg corrupting the url
$fmt =~ s/\?.+$//;
if(defined $self->{VIDEOFORMATS}{$fmt}) {
return $fmt;
}
}
return 'noconv';
}
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 = read_file($requestfile);
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';
}
$newm3ucontent .= $line . "\n";
}
# 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";
}
write_file($requestfile, $newm3ucontent);
return 1;
}
sub get_video_mkvinfo {
my ($request, $fileabspath) = @_;
my $matroska = matroska_open($fileabspath);
if(! $matroska) {
$request->Send404;
return;
}
my $obj;
if(defined $request->{'qs'}{'mkvinfo_time'}) {
my $track = matroska_get_video_track($matroska);
if(! $track) {
$request->Send404;
return;
}
my $gopinfo = matroska_get_gop($matroska, $track, $request->{'qs'}{'mkvinfo_time'});
if(! $gopinfo) {
$request->Send404;
return;
}
$obj = $gopinfo;
}
else {
$obj = {};
}
$obj->{duration} = $matroska->{'duration'};
$request->SendAsJSON($obj);
}
sub get_video_fmp4 {
my ($request, $fileabspath) = @_;
my @command = ('ffmpeg', '-loglevel', 'fatal');
if($request->{'qs'}{'fmp4_time'}) {
my $formattedtime = hls_audio_formattime($request->{'qs'}{'fmp4_time'});
push @command, ('-ss', $formattedtime);
}
push @command, ('-i', $fileabspath, '-c:v', 'copy', '-c:a', 'aac', '-f', 'mp4', '-movflags', 'frag_keyframe+empty_moov', '-');
my $evp = $request->{'client'}{'server'}{'evp'};
my $sent;
print "$_ " foreach @command;
$request->{'outheaders'}{'Accept-Ranges'} = 'none';
# avoid bookkeeping, have ffmpeg output straight to the socket
$request->{'outheaders'}{'Connection'} = 'close';
$request->{'outheaders'}{'Content-Type'} = 'video/mp4';
my $sock = $request->{'client'}{'sock'};
print $sock "HTTP/1.0 200 OK\r\n";
my $headtext = '';
foreach my $header (keys %{$request->{'outheaders'}}) {
$headtext .= "$header: " . $request->{'outheaders'}{$header} . "\r\n";
}
print $sock $headtext."\r\n";
$evp->remove($sock);
$request->{'client'} = undef;
MHFS::Process->cmd_to_sock(\@command, $sock);
}
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];
my $amount = $_[2];
my $lastelm = ($ebml->{'elements'} > 0) ? $ebml->{'elements'}[-1] : undef;
return undef if($lastelm && defined($lastelm->{'size'}) && ($amount > $lastelm->{'size'}));
my $amtread = read($ebml->{'fh'}, $$buf, $amount);
if(! $amtread) {
return $amtread;
}
foreach my $elem (@{$ebml->{'elements'}}) {
if($elem->{'size'}) {
$elem->{'size'} -= $amtread;
}
}
return $amtread;
}
sub ebml_seek {
my ($ebml, $position, $whence) = @_;
($whence == SEEK_CUR) or die("unsupported seek");
return undef if(($ebml->{'elements'} > 0) && $ebml->{'elements'}[-1]{'size'} && ($position > $ebml->{'elements'}[-1]{'size'}));
return undef if(!seek($ebml->{'fh'}, $position, $whence));
foreach my $elem (@{$ebml->{'elements'}}) {
if($elem->{'size'}) {
$elem->{'size'} -= $position;
}
}
return 1;
}
sub read_vint_from_buf {
my $bufref = $_[0];
my $savewidth = $_[1];
my $width = 1;
my $value = unpack('C', substr($$bufref, 0, 1, ''));
for(;;$width++) {
last if(($value << ($width-1)) & 0x80);
$width < 9 or return undef;
}
length($$bufref) >= ($width-1) or return undef;
for(my $wcopy = $width; $wcopy > 1; $wcopy--) {
$value <<= 8;
$value |= unpack('C', substr($$bufref, 0, 1, ''));
}
$$savewidth = $width;
return $value;
}
sub read_and_parse_vint_from_buf {
my $bufref = $_[0];
my $savewidth = $_[1];
my $width;
my $value = read_vint_from_buf($bufref, \$width);
defined($value) or return undef;
my $andval = 0xFF >> $width;
for(my $wcopy = $width; $wcopy > 1; $wcopy--) {
$andval <<= 8;
$andval |= 0xFF;
}
$value &= $andval;
if(defined $savewidth) {
$$savewidth = $width;
}
return $value;
}
sub read_vint {
my ($ebml, $val, $savewidth) = @_;
my $value;
ebml_read($ebml, $value, 1) or return 0;
my $width = 1;
$value = unpack('C', $value);
for(;;$width++) {
last if(($value << ($width-1)) & 0x80);
$width < 9 or return 0;
}
$$savewidth = $width;
my $byte;
for(; $width > 1; $width--) {
$value <<= 8;
ebml_read($ebml, $byte, 1) or return 0;
$value |= unpack('C', $byte);
}
$$val = $value;
return 1;
}
sub read_and_parse_vint {
my ($ebml, $val) = @_;
my $value;
my $width;
read_vint($ebml, \$value, \$width) or return 0;
my $andval = 0xFF >> $width;
for(;$width > 1; $width--) {
$andval <<= 8;
$andval |= 0xFF;
}
$value &= $andval;
$$val = $value;
return 1;
}
sub ebml_open {
my ($filename) = @_;
open(my $fh, "<", $filename) or return 0;
my $magic;
read($fh, $magic, 4) or return 0;
$magic eq "\x1A\x45\xDF\xA3" or return 0;
my $ebmlheadsize;
my $ebml = {'fh' => $fh, 'elements' => []};
read_and_parse_vint($ebml, \$ebmlheadsize) or return 0;
seek($fh, $ebmlheadsize, SEEK_CUR) or return 0;
return $ebml;
}
sub ebml_read_element {
my ($ebml) = @_;
my $id;
read_vint($ebml, \$id) or return undef;
my $size;
read_and_parse_vint($ebml, \$size) or return undef;
my $elm = {'id' => $id, 'size' => $size};
push @{$ebml->{'elements'}}, $elm;
return $elm;
}
sub ebml_skip {
my ($ebml) = @_;
my $elm = $ebml->{'elements'}[-1];
ebml_seek($ebml, $elm->{'size'}, SEEK_CUR) or return 0;
pop @{$ebml->{'elements'}};
return 1;
}
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) {
shift @elms;
$elm = $elms[0];
$elm->{'data'} = pop @bufstack;
}
elsif(! $elm->{'data'}) {
@elms = (@{$elm->{'elms'}}, undef, @elms);
push @bufstack, '';
next;
}
shift @elms;
my $elementid = $elm->{'id'};
if(! $elementid) {
print Dumper($elm);
die;
}
$elementid < 0xFFFFFFFF or return undef;
my $data = \$elm->{'data'};
my $size = length($$data);
$size < 0xFFFFFFFFFFFFFF or return undef;
# pack the id
my $buf;
if($elementid > 0xFFFFFF) {
# pack BE uint32_t
#$buf = pack('CCCC', ($elementid >> 24) & 0xFF, ($elementid >> 16) & 0xFF, ($elementid >> 8) & 0xFF, $elementid & 0xFF);
$buf = pack('N', $elementid);
}
elsif($elementid > 0xFFFF) {
# pack BE uint24_t
$buf = pack('CCC', ($elementid >> 16) & 0xFF, ($elementid >> 8) & 0xFF, $elementid & 0xFF);
}
elsif($elementid > 0xFF) {
# pack BE uint16_t
#$buf = pack('CC', ($elementid >> 8) & 0xFF, $elementid & 0xFF);
$buf = pack('n', $elementid);
}
else {
# pack BE uint8_t
$buf = pack('C', $elementid & 0xFF);
}
# pack the size
if($elm->{'infsize'}) {
$buf .= pack('C', 0xFF);
}
else {
# determine the VINT width and marker value, and the size needed for the vint
my $sizeflag = 0x80;
my $bitwidth = 0x8;
while($size >= $sizeflag) {
$bitwidth += 0x8;
$sizeflag <<= 0x7;
}
# Apply the VINT marker and pack the vint
$size |= $sizeflag;
while($bitwidth) {
$bitwidth -= 8;
$buf .= pack('C', ($size >> $bitwidth) & 0xFF);
}
}
# pack the data
$buf .= $$data;
$bufstack[-1] .= $buf;
}
return \$bufstack[0];
}
use constant {
'EBMLID_EBMLHead' => 0x1A45DFA3,
'EBMLID_EBMLVersion' => 0x4286,
'EBMLID_EBMLReadVersion' => 0x42F7,
'EBMLID_EBMLMaxIDLength' => 0x42F2,
'EBMLID_EBMLMaxSizeLength' => 0x42F3,
'EBMLID_EBMLDocType' => 0x4282,
'EBMLID_EBMLDocTypeVer' => 0x4287,
'EBMLID_EBMLDocTypeReadVer' => 0x4285,
'EBMLID_Segment' => 0x18538067,
'EBMLID_SegmentInfo' => 0x1549A966,
'EBMLID_TimestampScale' => 0x2AD7B1,
'EBMLID_Duration' => 0x4489,
'EBMLID_MuxingApp' => 0x4D80,
'EBMLID_WritingApp' => 0x5741,
'EBMLID_Tracks' => 0x1654AE6B,
'EBMLID_Track' => 0xAE,
'EBMLID_TrackNumber' => 0xD7,
'EBMLID_TrackUID' => 0x73C5,
'EBMLID_TrackType' => 0x83,
'EBMLID_DefaulDuration' => 0x23E383,
'EBMLID_CodecID' => 0x86,
'EBMLID_CodecPrivData', => 0x63A2,
'EBMLID_AudioTrack' => 0xE1,
'EBMLID_AudioChannels' => 0x9F,
'EBMLID_AudioSampleRate' => 0xB5,
'EBMLID_AudioBitDepth' => 0x6264,
'EBMLID_Cluster' => 0x1F43B675,
'EBMLID_ClusterTimestamp' => 0xE7,
'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, '');
my $lacing = unpack('C', $rawflag) & 0x6;
my $framecnt;
my @sizes;
# XIPH
if($lacing == 0x2) {
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
my $firstframessize = 0;
for(my $i = 0; $i < ($framecnt-1); $i++) {
my $fsize = 0;
while(1) {
my $val = unpack('C', substr($data, 0, 1, ''));
$fsize += $val;
last if($val < 255);
}
push @sizes, $fsize;
$firstframessize += $fsize;
}
push @sizes, (length($data) - $firstframessize);
}
# EBML
elsif($lacing == 0x6) {
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
my $last = read_and_parse_vint_from_buf(\$data);
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;
}
}
# no lacing
else {
push @sizes, length($data);
}
return {
'trackno' => $trackno,
'rawts' => $rawts,
'rawflag' => $rawflag,
'frame_lengths' => \@sizes,
'data' => $data,
'ts' => unpack('s>', $rawts)
};
}
sub telmval {
my ($track, $stringid) = @_;
my $constname = "EBMLID_$stringid";
my $id = __PACKAGE__->$constname;
return $track->{$id}{'value'} // $track->{$id}{'data'};
#return $track->{"$stringid"}}{'value'} // $track->{$EBMLID->{$stringid}}{'data'};
}
sub trackno_is_audio {
my ($tracks, $trackno) = @_;
foreach my $track (@$tracks) {
if(telmval($track, 'TrackNumber') == $trackno) {
return telmval($track, 'TrackType') == 0x2;
}
}
return undef;
}
sub flac_read_METADATA_BLOCK {
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
my ($buf) = @_;
my $metaBinString = unpack('B144', $buf);
my $x32 = 0 x 32;
my $info = {};
$info->{'MINIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 0, 16), -32)));
$info->{'MAXIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 16, 16), -32)));
$info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 32, 24), -32)));
$info->{'MAXIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 56, 24), -32)));
$info->{'SAMPLERATE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 80, 20), -32)));
$info->{'NUMCHANNELS'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 3), -32))) + 1;
$info->{'BITSPERSAMPLE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 103, 5), -32))) + 1;
# Calculate total samples in two parts
my $highBits = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 108, 4), -32)));
$info->{'TOTALSAMPLES'} = $highBits * 2 ** 32 +
unpack('N', pack('B32', substr($x32 . substr($metaBinString, 112, 32), -32)));
# Return the MD5 as a 32-character hexadecimal string
$info->{'MD5CHECKSUM'} = unpack('H32',substr($buf, 18, 16));
return $info;
}
sub flac_read_to_audio {
my ($fh) = @_;
my $buf;
my $magic = read($fh, $buf, 4);
($magic && ($magic == 4)) or return undef;
my $streaminfo;
for(;;) {
my $type;
my $done;
my $bref = flac_read_METADATA_BLOCK($fh, $type, $done);
$bref or return undef;
$buf .= $$bref;
if($type == 0) {
$streaminfo = flac_parseStreamInfo(substr($$bref, 4));
}
last if($done);
}
return {'streaminfo' => $streaminfo, 'buf' => \$buf};
}
sub parse_uinteger_str {
my ($str) = @_;
my @values = unpack('C'x length($str), $str);
my $value = 0;
my $shift = 0;
while(@values) {
$value |= ((pop @values) << $shift);
$shift += 8;
}
return $value;
}
sub parse_float_str {
my ($str) = @_;
return 0 if(length($str) == 0);
return unpack('f>', $str) if(length($str) == 4);
return unpack('d>', $str) if(length($str) == 8);
return undef;
}
# matroska object needs
# - ebml
# - tsscale
# - tracks
# - audio track, codec, channels, samplerate
# - video track, fps
# - duration
sub matroska_open {
my ($filename) = @_;
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;
}
# find tracks
my $in_tracks = ebml_find_id($ebml, EBMLID_Tracks);
if(!$in_tracks) {
return undef;
}
# 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'};
if(length($$dataref) >= $targetsize) {
return {'mime' => 'application/octet-stream', 'data' => substr($$dataref, 0, $targetsize, '')};
}
return undef;
});
my @tracks;
for(;;) {
my $in_track = ebml_find_id($ebml, EBMLID_Track);
if(! $in_track) {
ebml_skip($ebml);
last;
}
my %track = ('id' => EBMLID_Track);
for(;;) {
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'},
&EBMLID_AudioSampleRate => $track{&EBMLID_AudioSampleRate},
&EBMLID_AudioChannels => $track{&EBMLID_AudioChannels}
};
#$track{'outfmt'} = 'PCM';
#$track{'outChannels'} = $track{&EBMLID_AudioChannels};
$track{'outfmt'} = 'AAC';
$track{'outChannels'} = 2;
$track{'outPCMFrameLength'} = $CodecPCMFrameLength{$track{'outfmt'}};
$track{'outGetSegment'} = $CodecGetSegment{$track{'outfmt'}};
}
push @tracks, \%track;
}
if(scalar(@tracks) == 0) {
return undef;
}
my $segmentelm = $ebml->{'elements'}[0];
my %matroska = ('ebml' => $ebml, 'tsscale' => $tsval, 'rawduration' => $scaledduration, 'duration' => $duration, 'tracks' => \@tracks, 'segment_data_start' => {'size' => $segmentelm->{'size'}, 'id' => $segmentelm->{'id'}, 'fileoffset' => tell($ebml->{'fh'})}, 'curframe' => -1, 'curpaks' => []);
return \%matroska;
}
sub matroska_get_audio_track {
my ($matroska) = @_;
foreach my $track (@{$matroska->{'tracks'}}) {
my $tt = $track->{&EBMLID_TrackType};
if(defined $tt && ($tt->{'value'} == 2)) {
return $track;
}
}
return undef;
}
sub matroska_get_video_track {
my ($matroska) = @_;
foreach my $track (@{$matroska->{'tracks'}}) {
my $tt = $track->{&EBMLID_TrackType};
if(defined $tt && ($tt->{'value'} == 1)) {
return $track;
}
}
return undef;
}
sub matroska_read_cluster_metadata {
my ($matroska) = @_;
my $ebml = $matroska->{'ebml'};
# find a cluster
my $custer = ebml_find_id($ebml, EBMLID_Cluster);
return undef if(! $custer);
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;
}
ebml_skip($ebml);
}
return undef;
}
sub ebml_set_cluster {
my ($ebml, $cluster) = @_;
seek($ebml->{'fh'}, $cluster->{'fileoffset'}, SEEK_SET);
$ebml->{'elements'} = [
{
'id' => EBMLID_Segment,
'size' => $cluster->{'Segment_sizeleft'}
},
{
'id' => EBMLID_Cluster,
'size' => $cluster->{'size'}
}
];
}
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);
}
return undef;
}
sub matroska_ts_to_sample {
my ($matroska, $samplerate, $ts) = @_;
my $curframe = int(($ts * $samplerate / 1000000000)+ 0.5);
return $curframe;
}
sub matroska_get_gop {
my ($matroska, $track, $timeinseconds) = @_;
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
my $prevcluster;
my $desiredcluster;
while(1) {
my $cluster = matroska_read_cluster_metadata($matroska);
last if(!$cluster);
my $ctime = $cluster->{'ts'} / 1000000000;
# this cluster could have our GOP, save it's info
if($ctime <= $timeinseconds) {
$prevcluster = $desiredcluster;
$desiredcluster = $cluster;
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) {
$block = matroska_get_track_block($matroska, $tid);
if($block) {
$blocktime = matroska_calc_block_fullts($matroska, $block);
if($blocktime > $timeinseconds) {
$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'};
$matroska->{'curframe'} = 0;
$matroska->{'curpaks'} = [];
my $samplerate = $track->{&EBMLID_AudioSampleRate};
my $pcmFrameLen = $track->{'PCMFrameLength'};
if(!$pcmFrameLen) {
warn("Unknown codec");
return undef;
}
my $prevcluster;
my $desiredcluster;
while(1) {
my $cluster = matroska_read_cluster_metadata($matroska);
last if(!$cluster);
my $curframe = matroska_ts_to_sample($matroska, $samplerate, $cluster->{'ts'});
#$curframe = int(($curframe/$pcmFrameLen)+0.5)*$pcmFrameLen; # requires revert cluster
$curframe = ceil_div($curframe, $pcmFrameLen) * $pcmFrameLen;
# this cluster could contain our frame, save it's info
if($curframe <= $pcmFrameIndex) {
$prevcluster = $desiredcluster;
$desiredcluster = $cluster;
$desiredcluster->{'frameIndex'} = $curframe;
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) {
$block = matroska_get_track_block($matroska, $tid);
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'}};
$offset += $len;
$blockframe += $pcmFrameLen;
}
$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;
}
}
}
sub video_on_streams {
my ($video, $request, $continue) = @_;
$video->{'audio'} = [];
$video->{'video'} = [];
$video->{'subtitle'} = [];
my $input_file = $video->{'src_file'}{'filepath'};
my @command = ('ffmpeg', '-i', $input_file);
my $evp = $request->{'client'}{'server'}{'evp'};
MHFS::Process->new_output_process($evp, \@command, sub {
my ($output, $error) = @_;
my @lines = split(/\n/, $error);
my $current_stream;
my $current_element;
foreach my $eline (@lines) {
if($eline =~ /^\s*Stream\s#0:(\d+)(?:\((.+)\)){0,1}:\s(.+):\s(.+)(.*)$/) {
my $type = $3;
$current_stream = $1;
$current_element = { 'sindex' => $current_stream, 'lang' => $2, 'fmt' => $4, 'additional' => $5, 'metadata' => '' };
$current_element->{'is_default'} = 1 if($current_element->{'fmt'} =~ /\(default\)$/i);
$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";
write_file($video->{'out_location'} . '/duration', $video->{'duration'});
}
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;
}
}
}
print Dumper($video);
$continue->();
});
}
1;
}
package MHFS::Plugin::VideoLibrary {
use strict; use warnings;
use feature 'say';
use Encode qw(decode);
use URI::Escape qw (uri_escape);
MHFS::Util->import(qw(output_dir_versatile escape_html uri_escape_path));
sub player_video {
my ($request) = @_;
my $qs = $request->{'qs'};
my $server = $request->{'client'}{'server'};
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 = $server->GetResource($settings->{'DOCUMENTROOT'} . '/static/' . 'video_style.css');
$buf .= $$temp;
$buf .= '.searchfield { width: 50%; margin: 30px;}';
$buf .= '</style>';
$buf .= "</head>";
$buf .= "<body>";
$qs->{'action'} //= 'library';
# action=library
$buf .= '<div id="medialist">';
$qs->{'library'} //= 'all';
$qs->{'library'} = lc($qs->{'library'});
my @libraries = ('movies', 'tv', 'other');
if($qs->{'library'} ne 'all') {
@libraries = ($qs->{'library'});
}
my %libraryprint = ( 'movies' => 'Movies', 'tv' => 'TV', 'other' => 'Other');
print "plugin $_\n" foreach keys %{$server->{'loaded_plugins'}};
my $fmt = $server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}->video_get_format($qs->{'fmt'});
foreach my $library (@libraries) {
exists $settings->{'MEDIASOURCES'}{$library} or next;
my $lib = $settings->{'MEDIASOURCES'}{$library};
my $libhtmlcontent;
foreach my $sid (@$lib) {
my $sublib = $settings->{'SOURCES'}{$sid};
next if(! -d $sublib->{'folder'});
$libhtmlcontent .= ${video_library_html($sublib->{'folder'}, $library, $sid, {'fmt' => $fmt})};
}
next if(! $libhtmlcontent);
$buf .= "<h1>" . $libraryprint{$library} . "</h1><ul>\n";
$buf .= $libhtmlcontent.'</ul>';
}
$buf .= '</div>';
# add the video player
$temp = $server->GetResource($server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}{'VIDEOFORMATS'}{$fmt}->{'player_html'});
$buf .= $$temp;
$buf .= '<script>';
$temp = $server->GetResource($settings->{'DOCUMENTROOT'} . '/static/' . 'setVideo.js');
$buf .= $$temp;
$buf .= '</script>';
$buf .= "</body>";
$buf .= "</html>";
$request->SendHTML($buf);
}
sub video_library_html {
my ($dir, $lib, $sid, $opt) = @_;
my $fmt = $opt->{'fmt'};
my $urlconstant = 'lib='.$lib.'&sid='.$sid;
my $playlisturl = "playlist/video/$sid/";
my $buf;
output_dir_versatile($dir, {
'root' => $dir,
'min_file_size' => 100000,
'on_dir_start' => sub {
my ($realpath, $unsafe_relpath) = @_;
my $relpath = uri_escape($unsafe_relpath);
my $disppath = escape_html(decode('UTF-8', $unsafe_relpath));
$buf .= '<li><div class="row">';
$buf .= '<a href="#' . $relpath . '_hide" class="hide" id="' . $$disppath . '_hide">' . "$$disppath</a>";
$buf .= '<a href="#' . $relpath . '_show" class="show" id="' . $$disppath . '_show">' . "$$disppath</a>";
$buf .= ' <a href="'.$playlisturl . uri_escape_path($unsafe_relpath) . '?fmt=m3u8">M3U</a>';
$buf .= '<div class="list"><ul>';
},
'on_dir_end' => sub {
$buf .= '</ul></div></div></li>';
},
'on_file' => sub {
my ($realpath, $unsafe_relpath, $unsafe_name) = @_;
my $relpath = uri_escape($unsafe_relpath);
my $filename = escape_html(decode('UTF-8', $unsafe_name));
$buf .= '<li><a href="video?'.$urlconstant.'&name='.$relpath.'&fmt=' . $fmt . '" class="mediafile">' . $$filename . '</a> <a href="get_video?'.$urlconstant.'&name=' . $relpath . '&fmt=' . $fmt . '">DL</a> <a href="'.$playlisturl . uri_escape_path($unsafe_relpath) . '?fmt=m3u8">M3U</a></li>';
}
});
return \$buf;
}
sub new {
my ($class, $settings) = @_;
my $self = {};
bless $self, $class;
$self->{'routes'} = [
[
'/video', \&player_video
],
[
'/video/', sub {
my ($request) = @_;
$request->SendRedirect(301, '../video');
}
],
];
return $self;
}
1;
}
package App::MHFS; #Media Http File Server
use version; our $VERSION = version->declare("v0.6.0");
use strict; use warnings;
use feature 'say';
use Getopt::Long qw(GetOptions);
Getopt::Long::Configure qw(gnu_getopt);
our $USAGE = "Usage: $0 ".<<'END_USAGE';
[-h|--help] [-v|--version] [--flush] [--cfgdir <directory>] [--appdir <directory>]
[--fallback_data_root <directory>]
Media Http File Server - Stream your own music and video library via your
browser and standard media players.
All options are optional, provided to override settings.pl and defaults
--flush turn on autoflush for STDOUT and STDERR
--cfgdir location of configuration directory, will be created if
it does not exist
--appdir location of application static files
--fallback_data_root location to fallback to if setting isn't found instead of
$HOME or $APPDIR\mhfs
-h|--help print this message
-v|--version print version
END_USAGE
sub run {
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
# parse command line args into launchsettings
my %launchsettings;
my ($flush, $cfgdir, $fallback_data_root, $appdir, $help, $versionflag);
if(!GetOptions(
'flush' => \$flush,
'cfgdir=s' => \$cfgdir,
'fallback_data_root=s' => \$fallback_data_root,
'appdir=s' => \$appdir,
'--help|h' =>\$help,
'--version|v' => \$versionflag,
)) {
print STDERR "$0: Invalid param\n";
print STDERR $USAGE;
exit(1);
}
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);
# 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'],
);
}
1;
__END__
=pod
=encoding utf-8
=head1 NAME
App::MHFS - A Media HTTP File Server. Stream your own music and video
library via your browser and standard media players.
=head1 SYNOPSIS
use App::MHFS;
App::MHFS->run;
=head1 AUTHOR
Gavin Hayes, C<< <gahayes at cpan.org> >>
=head1 SUPPORT AND DOCUMENTATION
You can find documentation for this module with the perldoc command.
perldoc App::MHFS
Additional documentation, support, and bug reports can be found at the
MHFS repository L<https://github.com/G4Vi/MHFS>
=head1 LICENSE AND COPYRIGHT
This software is copyright (c) 2022 by Gavin Hayes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut