line
stmt
bran
cond
sub
pod
time
code
1
#!/usr/bin/perl
2
# Media HTTP File Server
3
4
# load this conditionally as it will faile if syscall.ph doesn't exist
5
0
0
BEGIN {
6
1
2
use constant HAS_EventLoop_Poll_Linux_Timer => eval {
7
1
2
package MHFS::EventLoop::Poll::Linux::Timer {
8
1
1
103074
use strict; use warnings;
1
1
3
1
29
1
51
1
3
1
41
9
1
1
487
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
7532
1
69
10
1
1
7
use POSIX qw/floor/;
1
2
1
8
11
1
1
3257
use Devel::Peek;
1
400
1
4
12
1
1
102
use feature 'say';
1
2
1
153
13
1
1
7
use Config;
1
2
1
98
14
1
50
10
if(index($Config{archname}, 'x86_64-linux') == -1) {
15
0
0
die("Unsupported arch: " . $Config{archname});
16
}
17
use constant {
18
1
685
_clock_REALTIME => 0,
19
_clock_MONOTONIC => 1,
20
_clock_BOOTTIME => 7,
21
_clock_REALTIME_ALARM => 8,
22
_clock_BOOTTIME_ALARM => 9,
23
24
_ENOTTY => 25, #constant for Linux?
25
1
1
7
};
1
2
26
# x86_64 numbers
27
1
216
require 'syscall.ph';
28
29
0
0
my $TFD_CLOEXEC = 0x80000;
30
0
0
my $TFD_NONBLOCK = 0x800;
31
32
sub new {
33
0
0
my ($class, $evp) = @_;
34
0
my $timerfd = syscall(SYS_timerfd_create(), _clock_MONOTONIC, $TFD_NONBLOCK | $TFD_CLOEXEC);
35
0
0
$timerfd != -1 or die("failed to create timerfd: $!");
36
0
my $timerhandle = IO::Handle->new_from_fd($timerfd, "r");
37
0
0
$timerhandle or die("failed to turn timerfd into a file handle");
38
0
my %self = ('timerfd' => $timerfd, 'timerhandle' => $timerhandle);
39
0
bless \%self, $class;
40
41
0
$evp->set($self{'timerhandle'}, \%self, POLLIN);
42
0
$self{'evp'} = $evp;
43
0
return \%self;
44
}
45
46
sub packitimerspec {
47
0
0
my ($times) = @_;
48
0
my $it_interval_sec = int($times->{'it_interval'});
49
0
my $it_interval_nsec = floor(($times->{'it_interval'} - $it_interval_sec) * 1000000000);
50
0
my $it_value_sec = int($times->{'it_value'});
51
0
my $it_value_nsec = floor(($times->{'it_value'} - $it_value_sec) * 1000000000);
52
#say "packing $it_interval_sec, $it_interval_nsec, $it_value_sec, $it_value_nsec";
53
0
return pack 'qqqq', $it_interval_sec, $it_interval_nsec, $it_value_sec, $it_value_nsec;
54
}
55
56
sub settime_linux {
57
0
0
my ($self, $start, $interval) = @_;
58
# assume start 0 is supposed to run immediately not try to cancel a timer
59
0
0
$start = ($start > 0.000000001) ? $start : 0.000000001;
60
0
my $new_value = packitimerspec({'it_interval' => $interval, 'it_value' => $start});
61
0
my $settime_success = syscall(SYS_timerfd_settime(), $self->{'timerfd'}, 0, $new_value,0);
62
0
0
($settime_success == 0) or die("timerfd_settime failed: $!");
63
}
64
65
sub onReadReady {
66
0
0
my ($self) = @_;
67
0
my $nread;
68
my $buf;
69
0
while($nread = sysread($self->{'timerhandle'}, $buf, 8)) {
70
0
0
if($nread < 8) {
71
0
say "timer hit, ignoring $nread bytes";
72
0
next;
73
}
74
0
my $expirations = unpack 'Q', $buf;
75
0
say "Linux::Timer there were $expirations expirations";
76
}
77
0
0
if(! defined $nread) {
78
1
0
1
509
if( ! $!{EAGAIN}) {
1
1324
1
8
0
79
0
say "sysread failed with $!";
80
}
81
82
}
83
0
$self->{'evp'}->check_timers;
84
0
return 1;
85
};
86
0
0
1;
87
} # package
88
1
1
153
}; # eval
1
0
2
89
}; # BEGIN
90
91
# You must provide event handlers for the events you are listening for
92
# return undef to have them removed from poll's structures
93
package MHFS::EventLoop::Poll::Base {
94
1
1
6
use strict; use warnings;
1
1
2
1
18
1
4
1
2
1
28
95
1
1
5
use feature 'say';
1
1
1
67
96
1
1
7
use POSIX ":sys_wait_h";
1
1
1
6
97
1
1
200
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
3
1
53
98
1
1
5
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
1
2
1
18
99
1
1
200
use Scalar::Util qw(looks_like_number);
1
2
1
56
100
1
1
653
use Data::Dumper;
1
6704
1
71
101
1
1
10
use Devel::Peek;
1
2
1
7
102
#use Devel::Refcount qw( refcount );
103
104
1
1
96
use constant POLLRDHUP => 0;
1
2
1
66
105
1
1
7
use constant ALWAYSMASK => (POLLRDHUP | POLLHUP);
1
1
1
1808
106
107
sub new {
108
0
0
my ($class) = @_;
109
0
my %self = ('poll' => IO::Poll->new(), 'fh_map' => {}, 'timers' => [], 'children' => {}, 'deadchildren' => []);
110
0
bless \%self, $class;
111
112
$SIG{CHLD} = sub {
113
0
0
while((my $child = waitpid(-1, WNOHANG)) > 0) {
114
0
my ($wstatus, $exitcode) = ($?, $?>> 8);
115
0
0
if(defined $self{'children'}{$child}) {
116
0
say "PID $child reaped (func) $exitcode";
117
0
push @{$self{'deadchildren'}}, [$self{'children'}{$child}, $child, $exitcode];
0
118
0
$self{'children'}{$child} = undef;
119
}
120
else {
121
0
say "PID $child reaped (No func) $exitcode";
122
}
123
}
124
0
};
125
126
0
return \%self;
127
}
128
129
sub register_child {
130
0
0
my ($self, $pid, $cb) = @_;
131
0
$self->{'children'}{$pid} = $cb;
132
}
133
134
sub run_dead_children_callbacks {
135
0
0
my ($self) = @_;
136
0
while(my $chld = shift(@{$self->{'deadchildren'}})) {
0
137
0
say "PID " . $chld->[1] . ' running SIGCHLD cb';
138
0
$chld->[0]($chld->[2]);
139
}
140
}
141
142
sub set {
143
0
0
my ($self, $handle, $obj, $events) = @_;
144
0
$self->{'poll'}->mask($handle, $events);
145
0
$self->{'fh_map'}{$handle} = $obj;
146
}
147
148
sub getEvents {
149
0
0
my ($self, $handle) = @_;
150
0
return $self->{'poll'}->mask($handle);
151
}
152
153
sub remove {
154
0
0
my ($self, $handle) = @_;
155
0
$self->{'poll'}->remove($handle);
156
0
$self->{'fh_map'}{$handle} = undef;
157
}
158
159
160
sub _insert_timer {
161
0
0
my ($self, $timer) = @_;
162
0
my $i;
163
0
0
for($i = 0; defined($self->{'timers'}[$i]) && ($timer->{'desired'} >= $self->{'timers'}[$i]{'desired'}); $i++) { }
164
0
splice @{$self->{'timers'}}, $i, 0, ($timer);
0
165
0
return $i;
166
}
167
168
169
# all times are relative, is 0 is set as the interval, it will be run every main loop iteration
170
# return undef in the callback to delete the timer
171
sub add_timer {
172
0
0
my ($self, $start, $interval, $callback, $id) = @_;
173
0
my $current_time = clock_gettime(CLOCK_MONOTONIC);
174
0
my $desired = $current_time + $start;
175
0
my $timer = { 'desired' => $desired, 'interval' => $interval, 'callback' => $callback };
176
0
0
$timer->{'id'} = $id if(defined $id);
177
0
return _insert_timer($self, $timer);
178
}
179
180
sub remove_timer_by_id {
181
0
0
my ($self, $id) = @_;
182
0
my $lastindex = scalar(@{$self->{'timers'}}) - 1;
0
183
0
for my $i (0 .. $lastindex) {
184
0
0
next if(! defined $self->{'timers'}[$i]{'id'});
185
0
0
if($self->{'timers'}[$i]{'id'} == $id) {
186
#say "Removing timer with id: $id";
187
0
splice(@{$self->{'timers'}}, $i, 1);
0
188
0
return;
189
}
190
}
191
0
say "unable to remove timer $id, not found";
192
}
193
194
sub requeue_timers {
195
0
0
my ($self, $timers, $current_time) = @_;
196
0
foreach my $timer (@$timers) {
197
0
$timer->{'desired'} = $current_time + $timer->{'interval'};
198
0
_insert_timer($self, $timer);
199
}
200
}
201
202
sub check_timers {
203
0
0
my ($self) = @_;
204
0
my @requeue_timers;
205
0
my $timerhit = 0;
206
0
my $current_time = clock_gettime(CLOCK_MONOTONIC);
207
0
while(my $timer = shift (@{$self->{'timers'}}) ) {
0
208
0
0
if($current_time >= $timer->{'desired'}) {
209
0
$timerhit = 1;
210
0
0
if(defined $timer->{'callback'}->($timer, $current_time, $self)) { # callback may change interval
211
0
push @requeue_timers, $timer;
212
}
213
}
214
else {
215
0
unshift @{$self->{'timers'}}, $timer;
0
216
0
last;
217
}
218
}
219
0
$self->requeue_timers(\@requeue_timers, $current_time);
220
}
221
222
sub do_poll {
223
0
0
my ($self, $loop_interval, $poll) = @_;
224
0
my $pollret = $poll->poll($loop_interval);
225
0
0
if($pollret > 0){
0
0
226
0
foreach my $handle ($poll->handles()) {
227
0
my $revents = $poll->events($handle);
228
0
my $obj = $self->{'fh_map'}{$handle};
229
0
0
if($revents & POLLIN) {
230
#say "read Ready " .$$;
231
0
0
if(! defined($obj->onReadReady)) {
232
0
$self->remove($handle);
233
0
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
234
0
next;
235
}
236
}
237
238
0
0
if($revents & POLLOUT) {
239
#say "writeReady";
240
0
0
if(! defined($obj->onWriteReady)) {
241
0
$self->remove($handle);
242
0
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
243
0
next;
244
}
245
}
246
247
0
0
if($revents & (POLLHUP | POLLRDHUP )) {
248
0
say "Hangup $handle, before ". scalar ( $self->{'poll'}->handles);
249
0
$obj->onHangUp();
250
0
$self->remove($handle);
251
0
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
252
}
253
}
254
255
}
256
elsif($pollret == 0) {
257
#say "pollret == 0";
258
}
259
elsif(! $!{EINTR}){
260
0
say "Poll ERROR $!";
261
#return undef;
262
}
263
264
0
$self->run_dead_children_callbacks;
265
}
266
267
sub run {
268
0
0
my ($self, $loop_interval) = @_;
269
0
0
my $default_lp_interval = $loop_interval // -1;
270
0
my $poll = $self->{'poll'};
271
0
for(;;)
272
{
273
0
check_timers($self);
274
0
print "do_poll $$";
275
0
0
if($self->{'timers'}) {
276
0
say " timers " . scalar(@{$self->{'timers'}}) . ' handles ' . scalar($self->{'poll'}->handles());
0
277
}
278
else {
279
0
print "\n";
280
}
281
# we don't need to expire until a timer is expiring
282
0
0
if(@{$self->{'timers'}}) {
0
283
0
$loop_interval = $self->{'timers'}[0]{'desired'} - clock_gettime(CLOCK_MONOTONIC);
284
}
285
else {
286
0
$loop_interval = $default_lp_interval;
287
}
288
0
do_poll($self, $loop_interval, $poll);
289
}
290
}
291
292
1;
293
}
294
295
package MHFS::EventLoop::Poll::Linux {
296
1
1
9
use strict; use warnings;
1
1
2
1
24
1
5
1
2
1
45
297
1
1
8
use feature 'say';
1
2
1
95
298
1
1
453
use parent -norequire, 'MHFS::EventLoop::Poll::Base';
1
301
1
6
299
sub new {
300
0
0
my $class = shift;
301
0
my $self = $class->SUPER::new(@_);
302
0
$self->{'evp_timer'} = MHFS::EventLoop::Poll::Linux::Timer->new($self);
303
0
return $self;
304
};
305
306
sub add_timer {
307
0
0
my ($self, $start) = @_;
308
0
shift @_;
309
0
0
if($self->SUPER::add_timer(@_) == 0) {
310
0
say __PACKAGE__.": add_timer, updating linux timer to $start";
311
0
$self->{'evp_timer'}->settime_linux($start, 0);
312
}
313
};
314
315
sub requeue_timers {
316
0
0
my $self = shift @_;
317
0
$self->SUPER::requeue_timers(@_);
318
0
my ($timers, $current_time) = @_;
319
0
0
if(@{$self->{'timers'}}) {
0
320
0
my $start = $self->{'timers'}[0]{'desired'} - $current_time;
321
0
say __PACKAGE__.": requeue_timers, updating linux timer to $start";
322
0
$self->{'evp_timer'}->settime_linux($start, 0);
323
}
324
};
325
326
sub run {
327
0
0
my ($self, $loop_interval) = @_;
328
0
0
$loop_interval //= -1;
329
0
my $poll = $self->{'poll'};
330
0
for(;;)
331
{
332
0
print __PACKAGE__.": do_poll LINUX_X86_64 $$";
333
0
0
if($self->{'timers'}) {
334
0
say " timers " . scalar(@{$self->{'timers'}}) . ' handles ' . scalar($self->{'poll'}->handles());
0
335
}
336
else {
337
0
print "\n";
338
}
339
340
0
$self->SUPER::do_poll($loop_interval, $poll);
341
}
342
};
343
1;
344
}
345
346
package MHFS::EventLoop::Poll {
347
1
1
430
use strict; use warnings;
1
1
3
1
18
1
4
1
2
1
37
348
1
1
7
use feature 'say';
1
2
1
188
349
350
my $selbackend;
351
BEGIN {
352
1
1
5
my @backends;
353
1
50
5
if(main::HAS_EventLoop_Poll_Linux_Timer) {
354
0
0
push @backends, "-norequire, 'MHFS::EventLoop::Poll::Linux'";
355
}
356
1
2
push @backends, "-norequire, 'MHFS::EventLoop::Poll::Base'";
357
358
1
2
foreach my $backend (@backends) {
359
1
50
1
97
if(eval "use parent $backend; 1;") {
1
7
1
2
1
4
360
1
3
$selbackend = $backend;
361
1
2
last;
362
}
363
}
364
1
50
54
$selbackend or die("Failed to load MHFS::EventLoop::Poll backend");
365
}
366
367
sub backend {
368
0
0
return $selbackend;
369
}
370
1;
371
}
372
373
package MHFS::HTTP::Server {
374
1
1
6
use strict; use warnings;
1
1
2
1
28
1
6
1
2
1
34
375
1
1
6
use feature 'say';
1
2
1
61
376
1
1
479
use IO::Socket::INET;
1
12663
1
6
377
1
1
452
use Socket qw(IPPROTO_TCP TCP_KEEPALIVE TCP_NODELAY);
1
2
1
207
378
1
1
7
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
2
1
65
379
1
1
7
use Scalar::Util qw(weaken);
1
2
1
41
380
1
1
15
use File::Path qw(make_path);
1
2
1
73
381
1
1
7
use Data::Dumper;
1
2
1
52
382
1
1
6
use Config;
1
2
1
378
383
384
MHFS::Util->import();
385
386
sub new {
387
0
0
my ($class, $launchsettings, $plugins, $routes) = @_;
388
389
$SIG{PIPE} = sub {
390
0
0
print STDERR "SIGPIPE @_\n";
391
0
};
392
393
0
binmode(STDOUT, ":utf8");
394
0
binmode(STDERR, ":utf8");
395
396
# load settings
397
0
say __PACKAGE__.": loading settings";
398
0
my $settings = MHFS::Settings::load($launchsettings);
399
0
0
0
if((exists $settings->{'flush'}) && ($settings->{'flush'})) {
400
0
say __PACKAGE__.": setting autoflush on STDOUT and STDERR";
401
0
STDOUT->autoflush(1);
402
0
STDERR->autoflush(1);
403
}
404
405
# make the temp dirs
406
0
make_path($settings->{'VIDEO_TMPDIR'}, $settings->{'MUSIC_TMPDIR'}, $settings->{'RUNTIME_DIR'}, $settings->{'GENERIC_TMPDIR'});
407
0
make_path($settings->{'SECRET_TMPDIR'}, {chmod => 0600});
408
0
make_path($settings->{'DATADIR'}, $settings->{'MHFS_TRACKER_TORRENT_DIR'});
409
410
0
my $sock = IO::Socket::INET->new(Listen => 10000, LocalAddr => $settings->{'HOST'}, LocalPort => $settings->{'PORT'}, Proto => 'tcp', Reuse => 1, Blocking => 0);
411
0
0
if(! $sock) {
412
0
say "server: Cannot create self socket";
413
0
return undef;
414
}
415
416
0
0
if(! $sock->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1)) {
417
0
say "server: cannot setsockopt";
418
0
return undef;
419
}
420
0
my $TCP_KEEPIDLE = 4;
421
0
my $TCP_KEEPINTVL = 5;
422
0
my $TCP_KEEPCNT = 6;
423
0
my $TCP_USER_TIMEOUT = 18;
424
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPIDLE, 1) or die;
425
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPINTVL, 1) or die;
426
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPCNT, 10) or die;
427
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_USER_TIMEOUT, 10000) or die; #doesn't work?
428
#$SERVER->setsockopt(SOL_SOCKET, SO_LINGER, pack("II",1,0)) or die; #to stop last ack
429
430
# leaving Nagle's algorithm enabled for now as sometimes headers are sent without data
431
#$sock->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1) or die("Failed to set TCP_NODELAY");
432
433
# linux specific settings. Check in BEGIN?
434
0
0
if(index($Config{osname}, 'linux') != -1) {
435
1
1
7
use Socket qw(TCP_QUICKACK);
1
3
1
888
436
0
0
$sock->setsockopt(IPPROTO_TCP, TCP_QUICKACK, 1) or die("Failed to set TCP_QUICKACK");
437
}
438
0
my $evp = MHFS::EventLoop::Poll->new;
439
0
0
my %self = ( 'settings' => $settings, 'routes' => $routes, 'route_default' => sub { $_[0]->SendDirectory($settings->{'DOCUMENTROOT'}); }, 'plugins' => $plugins, 'sock' => $sock, 'evp' => $evp, 'uploaders' => [], 'sesh' =>
0
440
{ 'newindex' => 0, 'sessions' => {}}, 'resources' => {}, 'loaded_plugins' => {});
441
0
bless \%self, $class;
442
443
0
$evp->set($sock, \%self, POLLIN);
444
445
0
my $fs = MHFS::FS->new($settings->{'SOURCES'});
446
0
0
if(! $fs) {
447
0
say "failed to open MHFS::FS";
448
0
return undef;
449
}
450
0
$self{'fs'} = $fs;
451
452
# load the plugins
453
0
foreach my $pluginname (@{$plugins}) {
0
454
455
0
0
0
next if(defined $settings->{$pluginname}{'enabled'} && (!$settings->{$pluginname}{'enabled'}));
456
0
my $plugin = $pluginname->new($settings, \%self);
457
0
0
next if(! $plugin);
458
459
0
foreach my $timer (@{$plugin->{'timers'}}) {
0
460
0
say __PACKAGE__.': adding '.ref($plugin).' timer';
461
0
$self{'evp'}->add_timer(@{$timer});
0
462
}
463
0
0
if(my $func = $plugin->{'uploader'}) {
464
0
say __PACKAGE__.': adding '. ref($plugin) .' uploader';
465
0
push (@{$self{'uploaders'}}, $func);
0
466
}
467
0
foreach my $route (@{$plugin->{'routes'}}) {
0
468
0
say __PACKAGE__.': adding ' . ref($plugin) . ' route ' . $route->[0];
469
0
push @{$self{'routes'}}, $route;
0
470
}
471
0
$plugin->{'server'} = \%self;
472
0
$self{'loaded_plugins'}{$pluginname} = $plugin;
473
}
474
475
0
$evp->run();
476
477
0
return \%self;
478
}
479
480
sub GetResource {
481
0
0
my ($self, $filename) = @_;
482
0
0
$self->{'resources'}{$filename} //= MHFS::Util::read_file($filename);
483
0
return \$self->{'resources'}{$filename};
484
}
485
486
sub onReadReady {
487
0
0
my ($server) = @_;
488
# accept the connection
489
0
my $csock = $server->{'sock'}->accept();
490
0
0
if(! $csock) {
491
0
say "server: cannot accept client";
492
0
return 1;
493
}
494
495
# gather connection details and verify client host is acceptable
496
0
my $peerhost = $csock->peerhost();
497
0
0
if(! $peerhost) {
498
0
say "server: no peerhost";
499
0
return 1;
500
}
501
0
my $peerip = MHFS::Util::ParseIPv4($peerhost);
502
0
0
if(! defined $peerip) {
503
0
say "server: error parsing ip";
504
0
return 1;
505
}
506
0
my $ah;
507
0
foreach my $allowedHost (@{$server->{'settings'}{'ARIPHOSTS_PARSED'}}) {
0
508
0
0
if(($peerip & $allowedHost->{'subnetmask'}) == $allowedHost->{'ip'}) {
509
0
$ah = $allowedHost;
510
0
last;
511
}
512
}
513
0
0
if(!$ah) {
514
0
say "server: $peerhost not allowed";
515
0
return 1;
516
}
517
0
my $peerport = $csock->peerport();
518
0
0
if(! $peerport) {
519
0
say "server: no peerport";
520
0
return 1;
521
}
522
523
# finally create the client
524
0
say "-------------------------------------------------";
525
0
say "NEW CONN " . $peerhost . ':' . $peerport;
526
0
my $cref = MHFS::HTTP::Server::Client->new($csock, $server, $ah, $peerip);
527
0
return 1;
528
}
529
530
1;
531
}
532
533
package MHFS::Util {
534
1
1
7
use strict; use warnings;
1
1
2
1
19
1
5
1
3
1
48
535
1
1
11
use feature 'say';
1
2
1
98
536
1
1
9
use Exporter 'import';
1
4
1
28
537
1
1
5
use File::Find;
1
2
1
76
538
1
1
7
use File::Basename;
1
2
1
100
539
1
1
6
use POSIX ();
1
3
1
30
540
1
1
6
use Cwd qw(abs_path getcwd);
1
2
1
57
541
1
1
581
use Encode qw(decode encode);
1
9799
1
83
542
1
1
442
use URI::Escape qw(uri_escape);
1
1615
1
1118
543
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', 'round', 'ceil_div', 'get_SI_size');
544
# single threaded locks
545
sub LOCK_GET_LOCKDATA {
546
0
0
my ($filename) = @_;
547
0
my $lockname = "$filename.lock";
548
0
my $bytes = read_file($lockname);
549
0
0
if(! defined $bytes) {
550
0
return undef;
551
}
552
0
return $bytes;
553
}
554
555
#sub LOCK_GET_FILESIZE {
556
# my ($filename) = @_;
557
# my $lockedfilesize = LOCK_GET_LOCKDATA($filename);
558
# if(defined $lockedfilesize) {
559
#
560
# }
561
#}
562
563
sub LOCK_WRITE {
564
0
0
my ($filename, $lockdata) = @_;
565
0
my $lockname = "$filename.lock";
566
0
0
if(-e $lockname) {
567
0
return 0;
568
}
569
0
0
$lockdata //= "99999999999"; #99 Billion
570
0
write_file($lockname, $lockdata);
571
0
return 1;
572
}
573
574
sub UNLOCK_WRITE {
575
0
0
my ($filename) = @_;
576
0
my $lockname = "$filename.lock";
577
0
unlink($lockname);
578
}
579
580
sub write_file {
581
0
0
my ($filename, $text) = @_;
582
0
0
open (my $fh, '>', $filename) or die("$! $filename");
583
0
print $fh $text;
584
0
close($fh);
585
}
586
587
588
sub read_file {
589
0
0
my ($filename) = @_;
590
0
return do {
591
0
local $/ = undef;
592
0
0
if(!(open my $fh, "<", $filename)) {
593
#say "could not open $filename: $!";
594
0
return undef;
595
}
596
else {
597
0
<$fh>;
598
}
599
};
600
}
601
602
# This is not fast
603
sub FindFile {
604
0
0
my ($directories, $name_req, $path_req) = @_;
605
0
my $curdir = getcwd();
606
0
my $foundpath;
607
0
eval {
608
0
my $dir_matches = 1;
609
my %options = ('wanted' => sub {
610
0
0
0
return if(! $dir_matches);
611
0
0
if(/$name_req/i) {
612
0
0
return if( -d );
613
0
$foundpath = $File::Find::name;
614
0
die;
615
}
616
0
});
617
618
0
0
if(defined $path_req) {
619
$options{'preprocess'} = sub {
620
0
0
$dir_matches = ($File::Find::dir =~ /$path_req/i);
621
0
return @_;
622
0
};
623
}
624
625
626
0
find(\%options, @$directories);
627
};
628
0
chdir($curdir);
629
0
return $foundpath;
630
}
631
632
sub shellcmd_unlock {
633
0
0
my ($command_arr, $fullpath) = @_;
634
0
system @$command_arr;
635
0
UNLOCK_WRITE($fullpath);
636
}
637
638
sub ASYNC {
639
0
0
my $func = shift;
640
0
my $pid = fork();
641
0
0
if($pid == 0) {
642
0
$func->(@_);
643
#exit 0;
644
0
POSIX::_exit(0);
645
}
646
else {
647
0
say "PID $pid ASYNC";
648
0
return $pid;
649
}
650
}
651
652
sub space2us {
653
0
0
my ($string) = @_;
654
0
$string =~ s/\s/_/g;
655
0
return $string;
656
}
657
sub escape_html {
658
0
0
my ($string) = @_;
659
0
my %dangerchars = ( '"' => '"', "'" => ''', '<' => '<', '>' => '>', '/' => '/');
660
0
$string =~ s/&/&/g;
661
0
foreach my $key(keys %dangerchars) {
662
0
my $val = $dangerchars{$key};
663
0
$string =~ s/$key/$val/g;
664
}
665
0
return \$string;
666
}
667
668
sub escape_html_noquote {
669
0
0
my ($string) = @_;
670
0
my %dangerchars = ('<' => '<', '>' => '>');
671
0
$string =~ s/&/&/g;
672
0
foreach my $key(keys %dangerchars) {
673
0
my $val = $dangerchars{$key};
674
0
$string =~ s/$key/$val/g;
675
}
676
0
return \$string;
677
}
678
679
sub function_exists {
680
1
1
8
no strict 'refs';
1
2
1
1998
681
0
0
my $funcname = shift;
682
0
0
return \&{$funcname} if defined &{$funcname};
0
0
683
0
return;
684
}
685
686
sub pid_running {
687
0
0
return kill 0, shift;
688
}
689
690
sub shell_escape {
691
0
0
my ($cmd) = @_;
692
0
($cmd) =~ s/'/'"'"'/g;
693
0
return $cmd;
694
}
695
696
sub output_dir_versatile {
697
0
0
my ($path, $options) = @_;
698
# hide the root path if desired
699
0
my $root = $options->{'root'};
700
0
0
$options->{'min_file_size'} //= 0;
701
702
0
my @files;
703
0
ON_DIR:
704
# get the list of files and sort
705
my $dir;
706
0
0
if(! opendir($dir, $path)) {
707
0
warn "outputdir: Cannot open directory: $path $!";
708
0
return;
709
}
710
0
my @newfiles = sort { uc($a) cmp uc($b)} (readdir $dir);
0
711
0
closedir($dir);
712
0
my @newpaths = ();
713
0
foreach my $file (@newfiles) {
714
0
0
next if($file =~ /^..?$/);
715
0
push @newpaths, "$path/$file";
716
}
717
0
0
@files = @files ? (@newpaths, undef, @files) : @newpaths;
718
0
while(@files)
719
{
720
0
$path = shift @files;
721
0
0
if(! defined $path) {
722
0
0
$options->{'on_dir_end'}->() if($options->{'on_dir_end'});
723
0
next;
724
}
725
0
my $file = basename($path);
726
0
0
if(-d $path) {
727
0
0
$options->{'on_dir_start'}->($path, $file) if($options->{'on_dir_start'});
728
0
goto ON_DIR;
729
}
730
731
0
my $unsafePath = $path;
732
0
0
if($root) {
733
0
$unsafePath =~ s/^$root(\/)?//;
734
}
735
0
my $size = -s $path;
736
0
0
if(! defined $size) {
737
0
say "size not defined path $path file $file";
738
0
next;
739
}
740
0
0
next if( $size < $options->{'min_file_size'});
741
0
0
$options->{'on_file'}->($path, $unsafePath, $file) if($options->{'on_file'});
742
}
743
0
return;
744
}
745
746
# perform multiple async actions at the same time.
747
# continue on with $result_func on failure or completion of all actions
748
sub do_multiples {
749
0
0
my ($multiples, $result_func) = @_;
750
0
my %data;
751
0
my @mkeys = keys %{$multiples};
0
752
0
foreach my $multiple (@mkeys) {
753
my $multiple_cb = sub {
754
0
0
my ($res) = @_;
755
0
$data{$multiple} = $res;
756
# return failure if this multiple failed
757
0
0
if(! defined $data{$multiple}) {
758
0
$result_func->(undef);
759
0
return;
760
}
761
# yield if not all the results in
762
0
foreach my $m2 (@mkeys) {
763
0
0
return if(! defined $data{$m2});
764
}
765
# all results in we can continue
766
0
$result_func->(\%data);
767
0
};
768
0
say "launching multiple key: $multiple";
769
0
$multiples->{$multiple}->($multiple_cb);
770
}
771
}
772
773
sub getMIME {
774
0
0
my ($filename) = @_;
775
776
0
my %combined = (
777
# audio
778
'mp3' => 'audio/mp3',
779
'flac' => 'audio/flac',
780
'opus' => 'audio',
781
'ogg' => 'audio/ogg',
782
'wav' => 'audio/wav',
783
# video
784
'mp4' => 'video/mp4',
785
'ts' => 'video/mp2t',
786
'mkv' => 'video/x-matroska',
787
'webm' => 'video/webm',
788
'flv' => 'video/x-flv',
789
# media
790
'mpd' => 'application/dash+xml',
791
'm3u8' => 'application/x-mpegURL',
792
'm3u8_v' => 'application/x-mpegURL',
793
# text
794
'html' => 'text/html; charset=utf-8',
795
'json' => 'application/json',
796
'js' => 'application/javascript',
797
'txt' => 'text/plain',
798
'css' => 'text/css',
799
# images
800
'jpg' => 'image/jpeg',
801
'jpeg' => 'image/jpeg',
802
'png' => 'image/png',
803
'gif' => 'image/gif',
804
'bmp' => 'image/bmp',
805
# binary
806
'pdf' => 'application/pdf',
807
'tar' => 'application/x-tar',
808
'wasm' => 'application/wasm',
809
'bin' => 'application/octet-stream'
810
);
811
812
0
my ($ext) = $filename =~ /\.([^.]+)$/;
813
814
# default to binary
815
0
0
return $combined{$ext} // $combined{'bin'};
816
}
817
818
sub ParseIPv4 {
819
0
0
my ($ipstring) = @_;
820
0
my @values = $ipstring =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
821
0
0
if(scalar(@values) != 4) {
822
0
return undef;
823
}
824
0
foreach my $i (0..3) {
825
0
0
($values[$i] <= 255) or return undef;
826
}
827
0
return ($values[0] << 24) | ($values[1] << 16) | ($values[2] << 8) | ($values[3]);
828
}
829
830
sub surrogatepairtochar {
831
0
0
my ($hi, $low) = @_;
832
0
my $codepoint = 0x10000 + (ord($hi) - 0xD800) * 0x400 + (ord($low) - 0xDC00);
833
0
return pack('U', $codepoint);
834
}
835
836
sub surrogatecodepointpairtochar {
837
0
0
my ($hi, $low) = @_;
838
0
my $codepoint = 0x10000 + ($hi - 0xD800) * 0x400 + ($low - 0xDC00);
839
0
return pack('U', $codepoint);
840
}
841
842
# returns the byte length and the codepoint
843
sub peek_utf8_codepoint {
844
0
0
my ($octets) = @_;
845
0
my @rules = (
846
[0xE0, 0xC0, 2], # 2 byte sequence
847
[0xF0, 0xE0, 3], # 3 byte sequence
848
[0XF8, 0xF0, 4] # 4 byte sequence
849
);
850
851
0
0
length($$octets) >= 1 or return undef;
852
0
my $byte = substr($$octets, 0, 1);
853
0
my $byteval = ord($byte);
854
0
my $charlen = 1;
855
0
foreach my $rule (@rules) {
856
0
0
if(($byteval & $rule->[0]) == $rule->[1]) {
857
0
$charlen = $rule->[2];
858
0
last;
859
}
860
}
861
0
0
length($octets) >= $charlen or return undef;
862
0
my $char = decode("utf8", substr($$octets, 0, $charlen));
863
0
0
if(length($char) > 1) {
864
0
return {'codepoint' => 0xFFFD, 'bytelength' => 1};
865
}
866
0
return { 'codepoint' => ord($char), 'bytelength' => $charlen};
867
}
868
869
sub get_printable_utf8 {
870
0
0
my ($octets) = @_;
871
872
#my $cp = ((0xF0 & 0x07) << 18) | ((0x9F & 0x3F) << 12) | ((0x8E & 0x3F) << 6) | (0x84 & 0x3F);
873
#say "codepoint $cp";
874
#
875
#my @tests = (
876
## #(chr(1 << 7) . chr(1 << 7)),
877
## #chr(0xED).chr(0xA0).chr(0xBC),
878
## #chr(0xED).chr(0xA0).chr(0xBC) . chr(1 << 7) . chr(1 << 7),
879
## #chr(0xED).chr(0xED).chr(0xED),
880
## chr(0xF0).chr(0xBF).chr(0xBF).chr(0xBF),
881
## chr(0xED).chr(0xA0),
882
## chr(0xF0).chr(0x9F).chr(0x8E).chr(0x84),
883
## chr(0xF0).chr(0x9F).chr(0x8E),
884
# chr(0xF0).chr(0x9F).chr(0x8E).chr(0x84),
885
# chr(0xF0).chr(0x9F).chr(0x8E).chr(0x04),
886
# chr(0x7F),
887
# chr(0xC1).chr(0x80),
888
# chr(0xC2).chr(0x80)
889
#);
890
##
891
#foreach my $test (@tests) {
892
# my $unsafedec = decode("utf8", $test, Encode::LEAVE_SRC);
893
# my $safedec = decode('UTF-8', $test);
894
# say "udec $unsafedec len ".length($unsafedec)." sdec $safedec len ".length($safedec);
895
# say "udec codepoint ".ord($unsafedec)." sdec codepoint " . ord($safedec);
896
#}
897
#die;
898
899
0
my $res;
900
0
while(length($octets)) {
901
0
$res .= decode('UTF-8', $octets, Encode::FB_QUIET);
902
0
0
last if(!length($octets));
903
904
# by default replace with the replacement char
905
0
my $chardata = peek_utf8_codepoint(\$octets);
906
0
my $toappend = chr(0xFFFD);
907
0
my $toremove = $chardata->{'bytelength'};
908
909
# if we find a surrogate pair, make the actual codepoint
910
0
0
0
if(($chardata->{'bytelength'} == 3) && ($chardata->{'codepoint'} >= 0xD800) && ($chardata->{'codepoint'} <= 0xDBFF)) {
0
911
0
my $secondchar = peek_utf8_codepoint(\substr($octets, 3, 3));
912
0
0
0
if($secondchar && ($secondchar->{'bytelength'} == 3) && ($secondchar->{'codepoint'} >= 0xDC00) && ($secondchar->{'codepoint'} <= 0xDFFF)) {
0
0
913
0
$toappend = surrogatecodepointpairtochar($chardata->{'codepoint'}, $secondchar->{'codepoint'});
914
0
$toremove += 3;
915
}
916
}
917
918
0
$res .= $toappend;
919
0
substr($octets, 0, $toremove, '');
920
}
921
922
0
return $res;
923
}
924
925
# save space by not precent encoding valid UTF-8 characters
926
sub small_url_encode {
927
0
0
my ($octets) = @_;
928
0
say "before $octets";
929
930
0
my $escapedoctets = ${escape_html($octets)};
0
931
0
my $res;
932
0
while(length($escapedoctets)) {
933
0
$res .= decode('UTF-8', $escapedoctets, Encode::FB_QUIET);
934
0
0
last if(!length($escapedoctets));
935
0
my $oct = ord(substr($escapedoctets, 0, 1, ''));
936
0
$res .= sprintf ("%%%02X", $oct);
937
}
938
0
say "now: $res";
939
0
return $res;
940
}
941
942
sub uri_escape_path {
943
0
0
my ($path) = @_;
944
0
my @components = split('/', $path);
945
0
my @encodedcomponents = map(uri_escape($_), @components);
946
0
return join('/', @encodedcomponents);
947
}
948
949
sub round {
950
0
0
return int($_[0]+0.5);
951
}
952
953
sub ceil_div {
954
0
0
return int(($_[0] + $_[1] - 1) / $_[1]);
955
}
956
957
sub get_SI_size {
958
0
0
my ($bytes) = @_;
959
0
my $mebibytes = ($bytes / 1048576);
960
0
0
if($mebibytes >= 1024) {
961
0
return sprintf("%.2f GiB", $bytes / 1073741824);
962
}
963
else {
964
0
return sprintf("%.2f MiB", $mebibytes);
965
}
966
}
967
968
1;
969
}
970
971
package MHFS::HTTP::Server::Client::Request {
972
MHFS::Util->import();
973
1
1
8
use strict; use warnings;
1
1
2
1
29
1
6
1
3
1
26
974
1
1
15
use feature 'say';
1
2
1
94
975
1
1
7
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
1
2
1
22
976
1
1
155
use URI::Escape;
1
2
1
60
977
1
1
7
use Cwd qw(abs_path getcwd);
1
2
1
42
978
1
1
6
use File::Basename;
1
2
1
63
979
1
1
485
use File::stat;
1
8768
1
4
980
1
1
70
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
2
1
50
981
1
1
6
use Data::Dumper;
1
2
1
43
982
1
1
6
use Scalar::Util qw(weaken);
1
2
1
40
983
1
1
5
use List::Util qw[min max];
1
3
1
71
984
1
1
6
use Symbol 'gensym';
1
2
1
62
985
1
1
6
use Devel::Peek;
1
3
1
8
986
1
1
100
use Encode qw(decode encode);
1
2
1
43
987
use constant {
988
1
60
MAX_REQUEST_SIZE => 8192,
989
1
1
5
};
1
11
990
1
1
472
use FindBin;
1
980
1
42
991
1
1
7
use File::Spec;
1
2
1
58
992
BEGIN {
993
1
50
1
106
if( ! (eval "use JSON; 1")) {
1
1
252
0
0
0
0
994
1
50
1
60
eval "use JSON::PP; 1" or die "No implementation of JSON available";
1
720
1
13743
1
61
995
1
122
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
996
}
997
}
998
999
# Optional dependency, Alien::Tar::Size
1000
BEGIN {
1001
1
1
9
use constant HAS_Alien_Tar_Size => (eval "use Alien::Tar::Size; 1");
1
1
2
1
57
1
530
1
38801
1
11
1002
1
1
7181
if(! HAS_Alien_Tar_Size) {
1003
warn "Alien::Tar::Size is not available";
1004
}
1005
}
1006
1007
sub new {
1008
0
0
my ($class, $client) = @_;
1009
0
my %self = ( 'client' => $client);
1010
0
bless \%self, $class;
1011
0
weaken($self{'client'}); #don't allow Request to keep client alive
1012
0
$self{'on_read_ready'} = \&want_request_line;
1013
0
$self{'outheaders'}{'X-MHFS-CONN-ID'} = $client->{'outheaders'}{'X-MHFS-CONN-ID'};
1014
0
$self{'rl'} = 0;
1015
# we want the request
1016
0
$client->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
1017
0
$self{'recvrequesttimerid'} = $client->AddClientCloseTimer($client->{'server'}{'settings'}{'recvrequestimeout'}, $client->{'CONN-ID'});
1018
0
return \%self;
1019
}
1020
1021
# on ready ready handlers
1022
sub want_request_line {
1023
0
0
my ($self) = @_;
1024
1025
0
my $ipos = index($self->{'client'}{'inbuf'}, "\r\n");
1026
0
0
if($ipos != -1) {
0
1027
0
0
if(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^\s]+)\s+([^\s]+)\s+(?:HTTP\/1\.([0-1])))\r\n/) {
1028
0
my $rl = $1;
1029
0
$self->{'method'} = $2;
1030
0
$self->{'uri'} = $3;
1031
0
$self->{'httpproto'} = $4;
1032
0
my $rid = int(clock_gettime(CLOCK_MONOTONIC) * rand()); # insecure uid
1033
0
$self->{'outheaders'}{'X-MHFS-REQUEST-ID'} = sprintf("%X", $rid);
1034
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . " X-MHFS-REQUEST-ID: " . $self->{'outheaders'}{'X-MHFS-REQUEST-ID'};
1035
0
say "RECV: $rl";
1036
0
0
0
if(($self->{'method'} ne 'GET') && ($self->{'method'} ne 'HEAD') && ($self->{'method'} ne 'PUT')) {
0
1037
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . 'Invalid method: ' . $self->{'method'}. ', closing conn';
1038
0
return undef;
1039
}
1040
0
my ($path, $querystring) = ($self->{'uri'} =~ /^([^\?]+)(?:\?)?(.*)$/g);
1041
0
say("raw path: $path\nraw querystring: $querystring");
1042
1043
# transformations
1044
## Path
1045
0
$path = uri_unescape($path);
1046
0
my %pathStruct = ( 'unescapepath' => $path );
1047
1048
# collapse slashes
1049
0
$path =~ s/\/{2,}/\//g;
1050
0
say "collapsed: $path";
1051
0
$pathStruct{'unsafecollapse'} = $path;
1052
1053
# without trailing slash
1054
0
0
if(index($pathStruct{'unsafecollapse'}, '/', length($pathStruct{'unsafecollapse'})-1) != -1) {
1055
0
chop($path);
1056
0
say "no slash path: $path ";
1057
}
1058
0
$pathStruct{'unsafepath'} = $path;
1059
1060
## Querystring
1061
0
my %qsStruct;
1062
# In the querystring spaces are sometimes encoded as + for legacy reasons unfortunately
1063
0
$querystring =~ s/\+/%20/g;
1064
0
my @qsPairs = split('&', $querystring);
1065
0
foreach my $pair (@qsPairs) {
1066
0
my($key, $value) = split('=', $pair);
1067
0
0
if(defined $value) {
1068
0
0
if(!defined $qsStruct{$key}) {
1069
0
$qsStruct{$key} = uri_unescape($value);
1070
}
1071
else {
1072
0
0
if(ref($qsStruct{$key}) ne 'ARRAY') {
1073
0
$qsStruct{$key} = [$qsStruct{$key}];
1074
};
1075
0
push @{$qsStruct{$key}}, uri_unescape($value);
0
1076
}
1077
}
1078
}
1079
1080
0
$self->{'path'} = \%pathStruct;
1081
0
$self->{'qs'} = \%qsStruct;
1082
0
$self->{'on_read_ready'} = \&want_headers;
1083
#return want_headers($self);
1084
0
goto &want_headers;
1085
}
1086
else {
1087
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid Request line, closing conn';
1088
0
return undef;
1089
}
1090
}
1091
elsif(length($self->{'client'}{'inbuf'}) > MAX_REQUEST_SIZE) {
1092
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' No Request line, closing conn';
1093
0
return undef;
1094
}
1095
0
return 1;
1096
}
1097
1098
sub want_headers {
1099
0
0
my ($self) = @_;
1100
0
my $ipos;
1101
0
while($ipos = index($self->{'client'}{'inbuf'}, "\r\n")) {
1102
0
0
if($ipos == -1) {
0
1103
0
0
if(length($self->{'client'}{'inbuf'}) > MAX_REQUEST_SIZE) {
1104
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Headers too big, closing conn';
1105
0
return undef;
1106
}
1107
0
return 1;
1108
}
1109
elsif(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^:]+):\s*(.*))\r\n/) {
1110
0
say "RECV: $1";
1111
0
$self->{'header'}{$2} = $3;
1112
}
1113
else {
1114
0
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid header, closing conn';
1115
0
return undef;
1116
}
1117
}
1118
# when $ipos is 0 we recieved the end of the headers: \r\n\r\n
1119
1120
# verify correct host is specified when required
1121
0
0
if($self->{'client'}{'serverhostname'}) {
1122
0
0
0
if((! $self->{'header'}{'Host'}) ||
1123
($self->{'header'}{'Host'} ne $self->{'client'}{'serverhostname'})) {
1124
0
0
my $printhostname = $self->{'header'}{'Host'} // '';
1125
0
say "Host: $printhostname does not match ". $self->{'client'}{'serverhostname'};
1126
0
return undef;
1127
}
1128
}
1129
1130
0
$self->{'ip'} = $self->{'client'}{'ip'};
1131
1132
# check if we're trusted (we can trust the headers such as from reverse proxy)
1133
0
my $trusted;
1134
0
0
0
if($self->{'client'}{'X-MHFS-PROXY-KEY'} && $self->{'header'}{'X-MHFS-PROXY-KEY'}) {
1135
0
$trusted = $self->{'client'}{'X-MHFS-PROXY-KEY'} eq $self->{'header'}{'X-MHFS-PROXY-KEY'};
1136
}
1137
# drops conns for naughty client's using forbidden headers
1138
0
0
if(!$trusted) {
1139
0
my @absolutelyforbidden = ('X-MHFS-PROXY-KEY', 'X-Forwarded-For');
1140
0
foreach my $forbidden (@absolutelyforbidden) {
1141
0
0
if( exists $self->{'header'}{$forbidden}) {
1142
0
say "header $forbidden is forbidden!";
1143
0
return undef;
1144
}
1145
}
1146
}
1147
# process reverse proxy headers
1148
else {
1149
0
delete $self->{'header'}{'X-MHFS-PROXY-KEY'};
1150
0
0
$self->{'ip'} = MHFS::Util::ParseIPv4($self->{'header'}{'X-Forwarded-For'}) if($self->{'header'}{'X-Forwarded-For'});
1151
}
1152
0
my $netmap = $self->{'client'}{'server'}{'settings'}{'NETMAP'};
1153
0
0
0
if($netmap && (($self->{'ip'} >> 24) == $netmap->[0])) {
1154
0
say "HACK for netmap converting to local ip";
1155
0
$self->{'ip'} = ($self->{'ip'} & 0xFFFFFF) | ($netmap->[1] << 24);
1156
}
1157
1158
# remove the final \r\n
1159
0
substr($self->{'client'}{'inbuf'}, 0, 2, '');
1160
0
0
0
if((defined $self->{'header'}{'Range'}) && ($self->{'header'}{'Range'} =~ /^bytes=([0-9]+)\-([0-9]*)$/)) {
1161
0
$self->{'header'}{'_RangeStart'} = $1;
1162
0
0
$self->{'header'}{'_RangeEnd'} = ($2 ne '') ? $2 : undef;
1163
}
1164
0
$self->{'on_read_ready'} = undef;
1165
0
$self->{'client'}->SetEvents(MHFS::EventLoop::Poll->ALWAYSMASK );
1166
0
$self->{'client'}->KillClientCloseTimer($self->{'recvrequesttimerid'});
1167
0
$self->{'recvrequesttimerid'} = undef;
1168
1169
# finally handle the request
1170
0
foreach my $route (@{$self->{'client'}{'server'}{'routes'}}) {
0
1171
0
0
if($self->{'path'}{'unsafecollapse'} eq $route->[0]) {
1172
0
$route->[1]($self);
1173
0
return 1;
1174
}
1175
else {
1176
# wildcard ending
1177
0
0
next if(index($route->[0], '*', length($route->[0])-1) == -1);
1178
0
0
next if(rindex($self->{'path'}{'unsafecollapse'}, substr($route->[0], 0, -1), 0) != 0);
1179
0
$route->[1]($self);
1180
0
return 1;
1181
}
1182
}
1183
0
$self->{'client'}{'server'}{'route_default'}($self);
1184
0
return 1;
1185
}
1186
1187
# unfortunately the absolute url of the server is required for stuff like m3u playlist generation
1188
sub getAbsoluteURL {
1189
0
0
my ($self) = @_;
1190
0
0
0
return $self->{'client'}{'absurl'} // (defined($self->{'header'}{'Host'}) ? 'http://'.$self->{'header'}{'Host'} : undef);
1191
}
1192
1193
sub _ReqDataLength {
1194
0
0
my ($self, $datalength) = @_;
1195
0
0
$datalength //= 99999999999;
1196
0
0
my $end = $self->{'header'}{'_RangeEnd'} // ($datalength-1);
1197
0
my $dl = $end+1;
1198
0
say "_ReqDataLength returning: $dl";
1199
0
return $dl;
1200
}
1201
1202
sub _SendResponse {
1203
0
0
my ($self, $fileitem) = @_;
1204
0
0
if(Encode::is_utf8($fileitem->{'buf'})) {
1205
0
warn "_SendResponse: UTF8 flag is set, turning off";
1206
0
Encode::_utf8_off($fileitem->{'buf'});
1207
}
1208
0
0
0
if($self->{'outheaders'}{'Transfer-Encoding'} && ($self->{'outheaders'}{'Transfer-Encoding'} eq 'chunked')) {
1209
0
say "chunked response";
1210
0
$fileitem->{'is_chunked'} = 1;
1211
}
1212
1213
0
$self->{'response'} = $fileitem;
1214
0
$self->{'client'}->SetEvents(POLLOUT | MHFS::EventLoop::Poll->ALWAYSMASK );
1215
}
1216
1217
sub _SendDataItem {
1218
0
0
my ($self, $dataitem, $opt) = @_;
1219
0
my $size = $opt->{'size'};
1220
0
my $code = $opt->{'code'};
1221
1222
0
0
if(! $code) {
1223
# if start is defined it's a range request
1224
0
0
if(defined $self->{'header'}{'_RangeStart'}) {
1225
0
$code = 206;
1226
}
1227
else {
1228
0
$code = 200;
1229
}
1230
}
1231
1232
0
my $contentlength;
1233
# range request
1234
0
0
if($code == 206) {
1235
0
my $start = $self->{'header'}{'_RangeStart'};
1236
0
my $end = $self->{'header'}{'_RangeEnd'};
1237
0
0
if(defined $end) {
0
1238
0
$contentlength = $end - $start + 1;
1239
}
1240
elsif(defined $size) {
1241
0
say 'Implicitly setting end to size';
1242
0
$end = $size - 1;
1243
0
$contentlength = $end - $start + 1;
1244
}
1245
# no end and size unknown. we have 4 choices:
1246
# 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 ...
1247
# send non partial response (200). This will often disable range requests.
1248
# send multipart. "A server MUST NOT generate a multipart response to a request for a single range"(RFC 7233 4.1) guess not
1249
1250
# LIE, use a large value to signify infinite size. RFC 8673 suggests doing so when client signifies it can.
1251
# Current clients don't however, so lets hope they can.
1252
else {
1253
0
say 'Implicitly setting end to 999999999999 to signify unknown end';
1254
0
$end = 999999999999;
1255
}
1256
1257
0
0
if($end < $start) {
1258
0
say "_SendDataItem, end < start";
1259
0
$self->Send403();
1260
0
return;
1261
}
1262
0
0
$self->{'outheaders'}{'Content-Range'} = "bytes $start-$end/" . ($size // '*');
1263
}
1264
# everybody else
1265
else {
1266
0
$contentlength = $size;
1267
}
1268
1269
# if the CL isn't known we need to send chunked
1270
0
0
if(! defined $contentlength) {
1271
0
$self->{'outheaders'}{'Transfer-Encoding'} = 'chunked';
1272
}
1273
else {
1274
0
$self->{'outheaders'}{'Content-Length'} = "$contentlength";
1275
}
1276
1277
1278
1279
0
my %lookup = (
1280
200 => "HTTP/1.1 200 OK\r\n",
1281
206 => "HTTP/1.1 206 Partial Content\r\n",
1282
301 => "HTTP/1.1 301 Moved Permanently\r\n",
1283
307 => "HTTP/1.1 307 Temporary Redirect\r\n",
1284
403 => "HTTP/1.1 403 Forbidden\r\n",
1285
404 => "HTTP/1.1 404 File Not Found\r\n",
1286
416 => "HTTP/1.1 416 Range Not Satisfiable\r\n",
1287
503 => "HTTP/1.1 503 Service Unavailable\r\n"
1288
);
1289
1290
0
my $headtext = $lookup{$code};
1291
0
0
if(!$headtext) {
1292
0
say "_SendDataItem, bad code $code";
1293
0
$self->Send403();
1294
0
return;
1295
}
1296
0
my $mime = $opt->{'mime'};
1297
0
$headtext .= "Content-Type: $mime\r\n";
1298
1299
0
my $filename = $opt->{'filename'};
1300
0
my $disposition = 'inline';
1301
0
0
if($opt->{'attachment'}) {
0
1302
0
$disposition = 'attachment';
1303
0
$filename = $opt->{'attachment'};
1304
}
1305
elsif($opt->{'inline'}) {
1306
0
$filename = $opt->{'inline'};
1307
}
1308
0
0
if($filename) {
1309
0
my $sendablebytes = encode('UTF-8', get_printable_utf8($filename));
1310
0
$headtext .= "Content-Disposition: $disposition; filename*=UTF-8''".uri_escape($sendablebytes)."; filename=\"$sendablebytes\"\r\n";
1311
}
1312
1313
0
0
$self->{'outheaders'}{'Accept-Ranges'} //= 'bytes';
1314
0
0
$self->{'outheaders'}{'Connection'} //= $self->{'header'}{'Connection'};
1315
0
0
$self->{'outheaders'}{'Connection'} //= 'keep-alive';
1316
1317
# SharedArrayBuffer
1318
0
0
if($opt->{'allowSAB'}) {
1319
0
say "sending SAB headers";
1320
0
$self->{'outheaders'}{'Cross-Origin-Opener-Policy'} = 'same-origin';
1321
0
$self->{'outheaders'}{'Cross-Origin-Embedder-Policy'} = 'require-corp';
1322
}
1323
1324
# serialize the outgoing headers
1325
0
foreach my $header (keys %{$self->{'outheaders'}}) {
0
1326
0
$headtext .= "$header: " . $self->{'outheaders'}{$header} . "\r\n";
1327
}
1328
1329
0
$headtext .= "\r\n";
1330
0
$dataitem->{'buf'} = $headtext;
1331
1332
0
0
if($dataitem->{'fh'}) {
1333
0
$dataitem->{'fh_pos'} = tell($dataitem->{'fh'});
1334
0
0
0
$dataitem->{'get_current_length'} //= sub { return undef };
0
1335
}
1336
1337
0
$self->_SendResponse($dataitem);
1338
}
1339
1340
sub Send403 {
1341
0
0
my ($self) = @_;
1342
0
my $msg = "403 Forbidden\r\n";
1343
0
$self->SendHTML($msg, {'code' => 403});
1344
}
1345
1346
sub Send404 {
1347
0
0
my ($self) = @_;
1348
0
my $msg = "404 Not Found";
1349
0
$self->SendHTML($msg, {'code' => 404});
1350
}
1351
1352
sub Send416 {
1353
0
0
my ($self, $cursize) = @_;
1354
0
$self->{'outheaders'}{'Content-Range'} = "*/$cursize";
1355
0
$self->SendHTML('', {'code' => 416});
1356
}
1357
1358
sub Send503 {
1359
0
0
my ($self) = @_;
1360
0
$self->{'outheaders'}{'Retry-After'} = 5;
1361
0
my $msg = "503 Service Unavailable";
1362
0
$self->SendHTML($msg, {'code' => 503});
1363
}
1364
1365
# requires already encoded url
1366
sub SendRedirectRawURL {
1367
0
0
my ($self, $code, $url) = @_;
1368
1369
0
$self->{'outheaders'}{'Location'} = $url;
1370
0
my $msg = "UNKNOWN REDIRECT MSG";
1371
0
0
if($code == 301) {
0
1372
0
$msg = "301 Moved Permanently";
1373
}
1374
elsif($code == 307) {
1375
0
$msg = "307 Temporary Redirect";
1376
}
1377
0
$msg .= "\r\n
1378
0
$self->SendHTML($msg, {'code' => $code});
1379
}
1380
1381
# encodes path and querystring
1382
# path and query string keys and values must be bytes not unicode string
1383
sub SendRedirect {
1384
0
0
my ($self, $code, $path, $qs) = @_;
1385
0
my $url;
1386
# encode the path component
1387
0
while(length($path)) {
1388
0
my $slash = index($path, '/');
1389
0
0
my $len = ($slash != -1) ? $slash : length($path);
1390
0
my $pathcomponent = substr($path, 0, $len, '');
1391
0
$url .= uri_escape($pathcomponent);
1392
0
0
if($slash != -1) {
1393
0
substr($path, 0, 1, '');
1394
0
$url .= '/';
1395
}
1396
}
1397
# encode the querystring
1398
0
0
if($qs) {
1399
0
$url .= '?';
1400
0
foreach my $key (keys %{$qs}) {
0
1401
0
my @values;
1402
0
0
if(ref($qs->{$key}) ne 'ARRAY') {
1403
0
push @values, $qs->{$key};
1404
}
1405
else {
1406
0
@values = @{$qs->{$key}};
0
1407
}
1408
0
foreach my $value (@values) {
1409
0
$url .= uri_escape($key).'='.uri_escape($value) . '&';
1410
}
1411
}
1412
0
chop $url;
1413
}
1414
1415
0
@_ = ($self, $code, $url);
1416
0
goto &SendRedirectRawURL;
1417
}
1418
1419
sub SendLocalFile {
1420
0
0
my ($self, $requestfile) = @_;
1421
0
my $start = $self->{'header'}{'_RangeStart'};
1422
0
my $client = $self->{'client'};
1423
1424
# open the file and get the size
1425
0
my %fileitem = ('requestfile' => $requestfile);
1426
0
my $currentsize;
1427
0
0
if($self->{'method'} ne 'HEAD') {
1428
0
my $FH;
1429
0
0
if(! open($FH, "<", $requestfile)) {
1430
0
say "SLF: open failed";
1431
0
$self->Send404;
1432
0
return;
1433
}
1434
0
binmode($FH);
1435
0
my $st = stat($FH);
1436
0
0
if(! $st) {
1437
0
$self->Send404();
1438
0
return;
1439
}
1440
0
$currentsize = $st->size;
1441
0
$fileitem{'fh'} = $FH;
1442
}
1443
else {
1444
0
$currentsize = (-s $requestfile);
1445
}
1446
1447
# seek if a start is specified
1448
0
0
if(defined $start) {
1449
0
0
if($start >= $currentsize) {
0
1450
0
$self->Send416($currentsize);
1451
0
return;
1452
}
1453
elsif($fileitem{'fh'}) {
1454
0
seek($fileitem{'fh'}, $start, 0);
1455
}
1456
}
1457
1458
# get the maximumly possible file size. 99999999999 signfies unknown
1459
my $get_current_size = sub {
1460
0
0
return $currentsize;
1461
0
};
1462
0
my $done;
1463
my $ts;
1464
my $get_max_size = sub {
1465
0
0
my $locksz = LOCK_GET_LOCKDATA($requestfile);
1466
0
0
if($done) {
1467
0
return $ts;
1468
}
1469
0
0
if(defined($locksz)) {
1470
0
0
$ts = ($locksz || 0);
1471
}
1472
else {
1473
0
$done = 1;
1474
0
0
$ts = ($get_current_size->() || 0);
1475
}
1476
0
};
1477
0
my $filelength = $get_max_size->();
1478
1479
# truncate to the [potentially] satisfiable end
1480
0
0
if(defined $self->{'header'}{'_RangeEnd'}) {
1481
0
$self->{'header'}{'_RangeEnd'} = min($filelength-1, $self->{'header'}{'_RangeEnd'});
1482
}
1483
1484
# setup callback for retrieving current file size if we are following the file
1485
0
0
if($fileitem{'fh'}) {
1486
0
0
if(! $done) {
1487
$get_current_size = sub {
1488
0
0
return stat($fileitem{'fh'})
1489
0
};
1490
}
1491
1492
my $get_read_filesize = sub {
1493
0
0
my $maxsize = $get_max_size->();
1494
0
0
if(defined $self->{'header'}{'_RangeEnd'}) {
1495
0
my $rangesize = $self->{'header'}{'_RangeEnd'}+1;
1496
0
0
return $rangesize if($rangesize <= $maxsize);
1497
}
1498
0
return $maxsize;
1499
0
};
1500
0
$fileitem{'get_current_length'} = $get_read_filesize;
1501
}
1502
1503
# flag to add SharedArrayBuffer headers
1504
0
my @SABwhitelist = ('static/music_worklet_inprogress/index.html');
1505
0
my $allowSAB;
1506
0
foreach my $allowed (@SABwhitelist) {
1507
0
0
if(index($requestfile, $allowed, length($requestfile)-length($allowed)) != -1) {
1508
0
$allowSAB = 1;
1509
0
last;
1510
}
1511
}
1512
1513
# finally build headers and send
1514
0
0
if($filelength == 99999999999) {
1515
0
$filelength = undef;
1516
}
1517
0
my $mime = getMIME($requestfile);
1518
1519
0
my $opt = {
1520
'size' => $filelength,
1521
'mime' => $mime,
1522
'allowSAB' => $allowSAB
1523
};
1524
0
0
if($self->{'responseopt'}{'cd_file'}) {
1525
0
$opt->{$self->{'responseopt'}{'cd_file'}} = basename($requestfile);
1526
}
1527
1528
0
$self->_SendDataItem(\%fileitem, $opt);
1529
}
1530
1531
# currently only supports fixed filelength
1532
sub SendPipe {
1533
0
0
my ($self, $FH, $filename, $filelength, $mime) = @_;
1534
0
0
if(! defined $filelength) {
1535
0
$self->Send404();
1536
}
1537
1538
0
0
$mime //= getMIME($filename);
1539
0
binmode($FH);
1540
0
my %fileitem;
1541
0
$fileitem{'fh'} = $FH;
1542
$fileitem{'get_current_length'} = sub {
1543
0
0
0
my $tocheck = defined $self->{'header'}{'_RangeEnd'} ? $self->{'header'}{'_RangeEnd'}+1 : $filelength;
1544
0
return min($filelength, $tocheck);
1545
0
};
1546
1547
0
$self->_SendDataItem(\%fileitem, {
1548
'size' => $filelength,
1549
'mime' => $mime,
1550
'filename' => $filename
1551
});
1552
}
1553
1554
# to do get rid of shell escape, launch ssh without blocking
1555
sub SendFromSSH {
1556
0
0
my ($self, $sshsource, $filename, $node) = @_;
1557
0
my @sshcmd = ('ssh', $sshsource->{'userhost'}, '-p', $sshsource->{'port'});
1558
0
my $fullescapedname = "'" . shell_escape($filename) . "'";
1559
0
my $folder = $sshsource->{'folder'};
1560
0
my $size = $node->[1];
1561
0
my @cmd;
1562
0
0
if(defined $self->{'header'}{'_RangeStart'}) {
1563
0
my $start = $self->{'header'}{'_RangeStart'};
1564
0
0
my $end = $self->{'header'}{'_RangeEnd'} // ($size - 1);
1565
0
my $bytestoskip = $start;
1566
0
my $count = $end - $start + 1;
1567
0
@cmd = (@sshcmd, 'dd', 'skip='.$bytestoskip, 'count='.$count, 'bs=1', 'if='.$fullescapedname);
1568
}
1569
else{
1570
0
@cmd = (@sshcmd, 'cat', $fullescapedname);
1571
}
1572
0
say "SendFromSSH (BLOCKING)";
1573
0
0
open(my $cmdh, '-|', @cmd) or die("SendFromSSH $!");
1574
1575
0
$self->SendPipe($cmdh, basename($filename), $size);
1576
0
return 1;
1577
}
1578
1579
# ENOTIMPLEMENTED
1580
sub Proxy {
1581
0
0
my ($self, $proxy, $node) = @_;
1582
0
die;
1583
0
return 1;
1584
}
1585
1586
# buf is a bytes scalar
1587
sub SendBytes {
1588
0
0
my ($self, $mime, $buf, $options) = @_;
1589
1590
# we want to sent in increments of bytes not characters
1591
0
0
if(Encode::is_utf8($buf)) {
1592
0
warn "SendBytes: UTF8 flag is set, turning off";
1593
0
Encode::_utf8_off($buf);
1594
}
1595
1596
0
my $bytesize = length($buf);
1597
1598
# only truncate buf if responding to a range request
1599
0
0
0
if((!$options->{'code'}) || ($options->{'code'} == 206)) {
1600
0
0
my $start = $self->{'header'}{'_RangeStart'} // 0;
1601
0
0
my $end = $self->{'header'}{'_RangeEnd'} // $bytesize-1;
1602
0
$buf = substr($buf, $start, ($end-$start) + 1);
1603
}
1604
1605
# Use perlio to read from the buf
1606
0
my $fh;
1607
0
0
if(!open($fh, '<', \$buf)) {
1608
0
$self->Send404;
1609
0
return;
1610
}
1611
my %fileitem = (
1612
'fh' => $fh,
1613
0
0
'get_current_length' => sub { return undef }
1614
0
);
1615
$self->_SendDataItem(\%fileitem, {
1616
'size' => $bytesize,
1617
'mime' => $mime,
1618
'filename' => $options->{'filename'},
1619
0
'code' => $options->{'code'}
1620
});
1621
}
1622
1623
# expects unicode string (not bytes)
1624
sub SendText {
1625
0
0
my ($self, $mime, $buf, $options) = @_;
1626
0
@_ = ($self, $mime, encode('UTF-8', $buf), $options);
1627
0
goto &SendBytes;
1628
}
1629
1630
# expects unicode string (not bytes)
1631
sub SendHTML {
1632
0
0
my ($self, $buf, $options) = @_;;
1633
0
@_ = ($self, 'text/html; charset=utf-8', encode('UTF-8', $buf), $options);
1634
0
goto &SendBytes;
1635
}
1636
1637
# expects perl data structure
1638
sub SendAsJSON {
1639
0
0
my ($self, $obj, $options) = @_;
1640
0
@_ = ($self, 'application/json', encode_json($obj), $options);
1641
0
goto &SendBytes;
1642
}
1643
1644
sub SendCallback {
1645
0
0
my ($self, $callback, $options) = @_;
1646
0
my %fileitem;
1647
0
$fileitem{'cb'} = $callback;
1648
1649
$self->_SendDataItem(\%fileitem, {
1650
'size' => $options->{'size'},
1651
'mime' => $options->{'mime'},
1652
0
'filename' => $options->{'filename'}
1653
});
1654
}
1655
1656
sub SendAsTar {
1657
0
0
my ($self, $requestfile) = @_;
1658
1659
0
if(!HAS_Alien_Tar_Size) {
1660
warn("Cannot send tar without Alien::Tar::Size");
1661
$self->Send404();
1662
return;
1663
}
1664
0
my ($libtarsize) = Alien::Tar::Size->dynamic_libs;
1665
0
0
if(!$libtarsize) {
1666
0
warn("Cannot find libtarsize");
1667
0
$self->Send404();
1668
0
return;
1669
}
1670
1671
# HACK, use LD_PRELOAD to hook tar to calculate the size quickly
1672
0
my @tarcmd = ('tar', '-C', dirname($requestfile), basename($requestfile), '-c', '--owner=0', '--group=0');
1673
$self->{'process'} = MHFS::Process->new(\@tarcmd, $self->{'client'}{'server'}{'evp'}, {
1674
'SIGCHLD' => sub {
1675
0
0
my $out = $self->{'process'}{'fd'}{'stdout'}{'fd'};
1676
0
my $size;
1677
0
read($out, $size, 50);
1678
0
chomp $size;
1679
0
say "size: $size";
1680
$self->{'process'} = MHFS::Process->new(\@tarcmd, $self->{'client'}{'server'}{'evp'}, {
1681
'STDOUT' => sub {
1682
0
my($out) = @_;
1683
0
say "tar sending response";
1684
0
$self->{'outheaders'}{'Accept-Ranges'} = 'none';
1685
0
my %fileitem = ('fh' => $out, 'get_current_length' => sub { return undef });
0
1686
0
$self->_SendDataItem(\%fileitem, {
1687
'size' => $size,
1688
'mime' => 'application/x-tar',
1689
'code' => 200,
1690
'attachment' => basename($requestfile).'.tar'
1691
});
1692
0
return 0;
1693
}
1694
0
});
1695
},
1696
},
1697
undef, # fd settings
1698
{
1699
0
'LD_PRELOAD' => $libtarsize
1700
});
1701
}
1702
1703
sub SendDirectory {
1704
0
0
my ($request, $droot) = @_;
1705
1706
# otherwise attempt to send a file from droot
1707
0
my $requestfile = abs_path($droot . $request->{'path'}{'unsafecollapse'});
1708
0
0
say "abs requestfile: $requestfile" if(defined $requestfile);
1709
1710
# not a file or is outside of the document root
1711
0
0
0
if(( ! defined $requestfile) ||
0
0
1712
(rindex($requestfile, $droot, 0) != 0)){
1713
0
$request->Send404;
1714
}
1715
# is regular file
1716
elsif (-f $requestfile) {
1717
0
0
if(index($request->{'path'}{'unsafecollapse'}, '/', length($request->{'path'}{'unsafecollapse'})-1) == -1) {
1718
0
$request->SendFile($requestfile);
1719
}
1720
else {
1721
0
$request->Send404;
1722
}
1723
}
1724
# is directory
1725
elsif (-d _) {
1726
# ends with slash
1727
0
0
if(index($request->{'path'}{'unescapepath'}, '/', length($request->{'path'}{'unescapepath'})-1) != -1) {
1728
0
my $index = $requestfile.'/index.html';
1729
0
0
if(-f $index) {
1730
0
$request->SendFile($index);
1731
0
return;
1732
}
1733
0
$request->Send404;
1734
}
1735
else {
1736
# redirect to slash path
1737
0
my $bn = basename($requestfile);
1738
0
$request->SendRedirect(301, $bn.'/');
1739
}
1740
}
1741
else {
1742
0
$request->Send404;
1743
}
1744
}
1745
1746
sub SendDirectoryListing {
1747
0
0
my ($self, $absdir, $urldir) = @_;
1748
0
my $urf = $absdir .'/'.substr($self->{'path'}{'unsafepath'}, length($urldir));
1749
0
my $requestfile = abs_path($urf);
1750
0
my $ml = $absdir;
1751
0
0
say "rf $requestfile " if(defined $requestfile);
1752
0
0
0
if (( ! defined $requestfile) || (rindex($requestfile, $ml, 0) != 0)){
1753
0
$self->Send404;
1754
0
return;
1755
}
1756
1757
0
0
if(-f $requestfile) {
0
1758
0
0
if(index($self->{'path'}{'unsafecollapse'}, '/', length($self->{'path'}{'unsafecollapse'})-1) == -1) {
1759
0
$self->SendFile($requestfile);
1760
}
1761
else {
1762
0
$self->Send404;
1763
}
1764
0
return;
1765
}
1766
elsif(-d _) {
1767
# ends with slash
1768
0
0
if((substr $self->{'path'}{'unescapepath'}, -1) eq '/') {
1769
0
0
opendir ( my $dh, $requestfile ) or die "Error in opening dir $requestfile\n";
1770
0
my $buf;
1771
my $filename;
1772
0
while( ($filename = readdir($dh))) {
1773
0
0
0
next if(($filename eq '.') || ($filename eq '..'));
1774
0
0
next if(!(-s "$requestfile/$filename"));
1775
0
my $url = uri_escape($filename);
1776
0
0
$url .= '/' if(-d _);
1777
0
$buf .= ''.${escape_html_noquote(decode('UTF-8', $filename, Encode::LEAVE_SRC))} .'
0
1778
}
1779
0
closedir($dh);
1780
0
$self->SendHTML($buf);
1781
0
return;
1782
}
1783
# redirect to slash path
1784
else {
1785
0
$self->SendRedirect(301, basename($requestfile).'/');
1786
0
return;
1787
}
1788
}
1789
0
$self->Send404;
1790
}
1791
1792
sub PUTBuf_old {
1793
0
0
my ($self, $handler) = @_;
1794
0
0
if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
1795
0
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
1796
}
1797
0
my $sdata;
1798
$self->{'on_read_ready'} = sub {
1799
0
0
my $contentlength = $self->{'header'}{'Content-Length'};
1800
0
$sdata .= $self->{'client'}{'inbuf'};
1801
0
my $dlength = length($sdata);
1802
0
0
if($dlength >= $contentlength) {
1803
0
say 'PUTBuf datalength ' . $dlength;
1804
0
my $data;
1805
0
0
if($dlength > $contentlength) {
1806
0
$data = substr($sdata, 0, $contentlength);
1807
0
$self->{'client'}{'inbuf'} = substr($sdata, $contentlength);
1808
0
$dlength = length($data)
1809
}
1810
else {
1811
0
$data = $sdata;
1812
0
$self->{'client'}{'inbuf'} = '';
1813
}
1814
0
$self->{'on_read_ready'} = undef;
1815
0
$handler->($data);
1816
}
1817
else {
1818
0
$self->{'client'}{'inbuf'} = '';
1819
}
1820
#return '';
1821
0
return 1;
1822
0
};
1823
0
$self->{'on_read_ready'}->();
1824
}
1825
1826
sub PUTBuf {
1827
0
0
my ($self, $handler) = @_;
1828
0
0
if($self->{'header'}{'Content-Length'} > 20000000) {
1829
0
say "PUTBuf too big";
1830
0
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
1831
0
0
$self->{'on_read_ready'} = sub { return undef };
0
1832
0
return;
1833
}
1834
0
0
if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
1835
0
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
1836
}
1837
$self->{'on_read_ready'} = sub {
1838
0
0
my $contentlength = $self->{'header'}{'Content-Length'};
1839
0
my $dlength = length($self->{'client'}{'inbuf'});
1840
0
0
if($dlength >= $contentlength) {
1841
0
say 'PUTBuf datalength ' . $dlength;
1842
0
my $data;
1843
0
0
if($dlength > $contentlength) {
1844
0
$data = substr($self->{'client'}{'inbuf'}, 0, $contentlength, '');
1845
}
1846
else {
1847
0
$data = $self->{'client'}{'inbuf'};
1848
0
$self->{'client'}{'inbuf'} = '';
1849
}
1850
0
$self->{'on_read_ready'} = undef;
1851
0
$handler->($data);
1852
}
1853
0
return 1;
1854
0
};
1855
0
$self->{'on_read_ready'}->();
1856
}
1857
1858
sub SendFile {
1859
0
0
my ($self, $requestfile) = @_;
1860
0
foreach my $uploader (@{$self->{'client'}{'server'}{'uploaders'}}) {
0
1861
0
0
return if($uploader->($self, $requestfile));
1862
}
1863
0
say "SendFile - SendLocalFile $requestfile";
1864
0
return $self->SendLocalFile($requestfile);
1865
}
1866
1867
1;
1868
}
1869
1870
package MHFS::HTTP::Server::Client {
1871
1
1
11
use strict; use warnings;
1
1
3
1
21
1
6
1
2
1
41
1872
1
1
7
use feature 'say';
1
2
1
114
1873
1
1
7
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
1
3
1
7
1874
1
1
146
use IO::Socket::INET;
1
3
1
14
1875
1
1
606
use Errno qw(EINTR EIO :POSIX);
1
2
1
410
1876
1
1
7
use Fcntl qw(:seek :mode);
1
2
1
272
1877
1
1
7
use File::stat;
1
2
1
8
1878
1
1
54
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
4
1
71
1879
1
1
7
use Scalar::Util qw(looks_like_number weaken);
1
3
1
48
1880
1
1
15
use Data::Dumper;
1
3
1
44
1881
1
1
5
use Carp;
1
2
1
601
1882
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
1883
1884
sub new {
1885
0
0
my ($class, $sock, $server, $serverhostinfo, $ip) = @_;
1886
0
$sock->blocking(0);
1887
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'});
1888
0
$self{'CONN-ID'} = int($self{'time'} * rand()); # insecure uid
1889
0
$self{'outheaders'}{'X-MHFS-CONN-ID'} = sprintf("%X", $self{'CONN-ID'});
1890
0
bless \%self, $class;
1891
0
$self{'request'} = MHFS::HTTP::Server::Client::Request->new(\%self);
1892
0
return \%self;
1893
}
1894
1895
# add a connection timeout timer
1896
sub AddClientCloseTimer {
1897
0
0
my ($self, $timelength, $id) = @_;
1898
0
weaken($self); #don't allow this timer to keep the client object alive
1899
0
my $server = $self->{'server'};
1900
0
say "CCT | add timer: $id";
1901
$server->{'evp'}->add_timer($timelength, 0, sub {
1902
0
0
0
if(! defined $self) {
1903
0
say "CCT | $id self undef";
1904
0
return undef;
1905
}
1906
#(defined $self) or return undef;
1907
0
say "CCT | \$timelength ($timelength) exceeded, closing CONN $id";
1908
0
say "-------------------------------------------------";
1909
0
$server->{'evp'}->remove($self->{'sock'});
1910
0
say "poll has " . scalar ( $server->{'evp'}{'poll'}->handles) . " handles";
1911
0
return undef;
1912
0
}, $id);
1913
0
return $id;
1914
}
1915
1916
sub KillClientCloseTimer {
1917
0
0
my ($self, $id) = @_;
1918
0
my $server = $self->{'server'};
1919
0
say "CCT | removing timer: $id";
1920
0
$server->{'evp'}->remove_timer_by_id($id);
1921
}
1922
1923
sub SetEvents {
1924
0
0
my ($self, $events) = @_;
1925
0
$self->{'server'}{'evp'}->set($self->{'sock'}, $self, $events);
1926
}
1927
1928
use constant {
1929
1
2135
RECV_SIZE => 65536,
1930
CT_YIELD => 1,
1931
CT_DONE => undef,
1932
#CT_READ => 1,
1933
#CT_PROCESS = 2,
1934
#CT_WRITE => 3
1935
1
1
7
};
1
3
1936
1937
# The "client_thread" consists of 5 states, CT_READ, CT_PROCESS, CT_WRITE, CT_YIELD, and CT_DONE
1938
# CT_READ reads input data from the socket
1939
## on data read transitions to CT_PROCESS
1940
## on error transitions to CT_DONE
1941
## otherwise CT_YIELD
1942
1943
# CT_PROCESS processes the input data
1944
## on processing done, switches to CT_WRITE or CT_READ to read more data to process
1945
## on error transitions to CT_DONE
1946
## otherwise CT_YIELD
1947
1948
# CT_WRITE outputs data to the socket
1949
## on all data written transitions to CT_PROCESS unless Connection: close is set.
1950
## on error transitions to CT_DONE
1951
## otherwise CT_YIELD
1952
1953
# CT_YIELD just returns control to the poll loop to wait for IO or allow another client thread to run
1954
1955
# 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
1956
1957
sub CT_READ {
1958
0
0
my ($self) = @_;
1959
0
my $tempdata;
1960
0
0
if(!defined($self->{'sock'}->recv($tempdata, RECV_SIZE))) {
1961
0
0
0
if(! ($!{EAGAIN} || $!{EWOULDBLOCK})) {
1962
0
print ("CT_READ RECV errno: $!\n");
1963
0
return CT_DONE;
1964
}
1965
0
say "CT_YIELD: $!";
1966
0
return CT_YIELD;
1967
}
1968
0
0
if(length($tempdata) == 0) {
1969
0
say 'Server::Client read 0 bytes, client read closed';
1970
0
return CT_DONE;
1971
}
1972
0
$self->{'inbuf'} .= $tempdata;
1973
0
goto &CT_PROCESS;
1974
}
1975
1976
sub CT_PROCESS {
1977
0
0
my ($self) = @_;
1978
0
0
$self->{'request'} //= MHFS::HTTP::Server::Client::Request->new($self);
1979
0
0
if(!defined($self->{'request'}{'on_read_ready'})) {
1980
0
die("went into CT_PROCESS in bad state");
1981
0
return CT_YIELD;
1982
}
1983
0
my $res = $self->{'request'}{'on_read_ready'}->($self->{'request'});
1984
0
0
if(!$res) {
1985
0
return $res;
1986
}
1987
0
0
if(defined $self->{'request'}{'response'}) {
0
1988
0
goto &CT_WRITE;
1989
}
1990
elsif(defined $self->{'request'}{'on_read_ready'}) {
1991
0
goto &CT_READ;
1992
}
1993
0
return $res;
1994
}
1995
1996
sub CT_WRITE {
1997
0
0
my ($self) = @_;
1998
0
0
if(!defined $self->{'request'}{'response'}) {
1999
0
die("went into CT_WRITE in bad state");
2000
0
return CT_YIELD;
2001
}
2002
# TODO only TrySendResponse if there is data in buf or to be read
2003
0
my $tsrRet = $self->TrySendResponse;
2004
0
0
if(!defined($tsrRet)) {
0
2005
0
say "-------------------------------------------------";
2006
0
return CT_DONE;
2007
}
2008
elsif($tsrRet ne '') {
2009
0
0
0
if($self->{'request'}{'outheaders'}{'Connection'} && ($self->{'request'}{'outheaders'}{'Connection'} eq 'close')) {
2010
0
say "Connection close header set closing conn";
2011
0
say "-------------------------------------------------";
2012
0
return CT_DONE;
2013
}
2014
0
$self->{'request'} = undef;
2015
0
goto &CT_PROCESS;
2016
}
2017
0
return CT_YIELD;
2018
}
2019
2020
sub do_on_data {
2021
0
0
my ($self) = @_;
2022
0
my $res = $self->{'request'}{'on_read_ready'}->($self->{'request'});
2023
0
0
if($res) {
2024
0
0
if(defined $self->{'request'}{'response'}) {
0
2025
#say "do_on_data: goto onWriteReady";
2026
0
goto &onWriteReady;
2027
#return onWriteReady($self);
2028
}
2029
#else {
2030
elsif(defined $self->{'request'}{'on_read_ready'}) {
2031
#say "do_on_data: goto onReadReady inbuf " . length($self->{'inbuf'});
2032
0
goto &onReadReady;
2033
#return onReadReady($self);
2034
}
2035
else {
2036
0
say "do_on_data: response and on_read_ready not defined, response by timer or poll?";
2037
}
2038
}
2039
0
return $res;
2040
}
2041
2042
2043
sub onReadReady {
2044
0
0
goto &CT_READ;
2045
0
my ($self) = @_;
2046
0
my $tempdata;
2047
0
0
if(defined($self->{'sock'}->recv($tempdata, RECV_SIZE))) {
2048
0
0
if(length($tempdata) == 0) {
2049
0
say 'Server::Client read 0 bytes, client read closed';
2050
0
return undef;
2051
}
2052
0
$self->{'inbuf'} .= $tempdata;
2053
0
goto &do_on_data;
2054
}
2055
0
0
if(! $!{EAGAIN}) {
2056
0
print ("MHFS::HTTP::Server::Client onReadReady RECV errno: $!\n");
2057
0
return undef;
2058
}
2059
0
return '';
2060
}
2061
2062
sub onWriteReady {
2063
0
0
goto &CT_WRITE;
2064
0
my ($client) = @_;
2065
# send the response
2066
0
0
if(defined $client->{'request'}{'response'}) {
2067
# TODO only TrySendResponse if there is data in buf or to be read
2068
0
my $tsrRet = $client->TrySendResponse;
2069
0
0
if(!defined($tsrRet)) {
0
2070
0
say "-------------------------------------------------";
2071
0
return undef;
2072
}
2073
elsif($tsrRet ne '') {
2074
0
0
0
if($client->{'request'}{'outheaders'}{'Connection'} && ($client->{'request'}{'outheaders'}{'Connection'} eq 'close')) {
2075
0
say "Connection close header set closing conn";
2076
0
say "-------------------------------------------------";
2077
0
return undef;
2078
}
2079
0
$client->{'request'} = MHFS::HTTP::Server::Client::Request->new($client);
2080
# handle possible existing read data
2081
0
goto &do_on_data;
2082
}
2083
}
2084
else {
2085
0
say "response not defined, probably set later by a timer or poll";
2086
}
2087
0
return 1;
2088
}
2089
2090
sub _TSRReturnPrint {
2091
0
0
my ($sentthiscall) = @_;
2092
0
0
if($sentthiscall > 0) {
2093
0
say "wrote $sentthiscall bytes";
2094
}
2095
}
2096
2097
sub TrySendResponse {
2098
0
0
my ($client) = @_;
2099
0
my $csock = $client->{'sock'};
2100
0
my $dataitem = $client->{'request'}{'response'};
2101
0
0
defined($dataitem->{'buf'}) or die("dataitem must always have a buf");
2102
0
my $sentthiscall = 0;
2103
do {
2104
# Try to send the buf if set
2105
0
0
if(length($dataitem->{'buf'})) {
2106
0
my $sret = TrySendItem($csock, \$dataitem->{'buf'});
2107
# critical conn error
2108
0
0
if(! defined($sret)) {
2109
0
_TSRReturnPrint($sentthiscall);
2110
0
return undef;
2111
}
2112
0
0
if($sret) {
2113
0
$sentthiscall += $sret;
2114
# if we sent data, kill the send timer
2115
0
0
if(defined $client->{'sendresponsetimerid'}) {
2116
0
$client->KillClientCloseTimer($client->{'sendresponsetimerid'});
2117
0
$client->{'sendresponsetimerid'} = undef;
2118
}
2119
}
2120
# not all data sent, add timer
2121
0
0
if(length($dataitem->{'buf'}) > 0) {
2122
0
0
$client->{'sendresponsetimerid'} //= $client->AddClientCloseTimer($client->{'server'}{'settings'}{'sendresponsetimeout'}, $client->{'CONN-ID'});
2123
0
_TSRReturnPrint($sentthiscall);
2124
0
return '';
2125
}
2126
2127
#we sent the full buf
2128
}
2129
2130
# read more data
2131
0
my $newdata;
2132
0
0
if(defined $dataitem->{'fh'}) {
0
2133
0
my $FH = $dataitem->{'fh'};
2134
0
my $req_length = $dataitem->{'get_current_length'}->();
2135
0
my $filepos = $dataitem->{'fh_pos'};
2136
# TODO, remove this assert
2137
0
0
if($filepos != tell($FH)) {
2138
0
die('tell mismatch');
2139
}
2140
0
0
0
if($req_length && ($filepos >= $req_length)) {
2141
0
0
if($filepos > $req_length) {
2142
0
say "Reading too much tell: $filepos req_length: $req_length";
2143
}
2144
0
say "file read done";
2145
0
close($FH);
2146
}
2147
else {
2148
0
my $readamt = 24000;
2149
0
0
if($req_length) {
2150
0
my $tmpsend = $req_length - $filepos;
2151
0
0
$readamt = $tmpsend if($tmpsend < $readamt);
2152
}
2153
# this is blocking, it shouldn't block for long but it could if it's a pipe especially
2154
0
my $bytesRead = read($FH, $newdata, $readamt);
2155
0
0
if(! defined($bytesRead)) {
0
2156
0
$newdata = undef;
2157
0
say "READ ERROR: $!";
2158
}
2159
elsif($bytesRead == 0) {
2160
# read EOF, better remove the error
2161
0
0
if(! $req_length) {
2162
0
say '$req_length not set and read 0 bytes, treating as EOF';
2163
0
$newdata = undef;
2164
}
2165
else {
2166
0
say 'FH EOF ' .$filepos;
2167
0
seek($FH, 0, 1);
2168
0
_TSRReturnPrint($sentthiscall);
2169
0
return '';
2170
}
2171
}
2172
else {
2173
0
$dataitem->{'fh_pos'} += $bytesRead;
2174
}
2175
}
2176
}
2177
elsif(defined $dataitem->{'cb'}) {
2178
0
$newdata = $dataitem->{'cb'}->($dataitem);
2179
}
2180
2181
0
my $encode_chunked = $dataitem->{'is_chunked'};
2182
# if we got to here and there's no data, fetching newdata is done
2183
0
0
if(! $newdata) {
2184
0
$dataitem->{'fh'} = undef;
2185
0
$dataitem->{'cb'} = undef;
2186
0
$dataitem->{'is_chunked'} = undef;
2187
0
$newdata = '';
2188
}
2189
2190
# encode chunked encoding if needed
2191
0
0
if($encode_chunked) {
2192
0
my $sizeline = sprintf "%X\r\n", length($newdata);
2193
0
$newdata = $sizeline.$newdata."\r\n";
2194
}
2195
2196
# add the new data to the dataitem buffer
2197
0
$dataitem->{'buf'} .= $newdata;
2198
2199
0
} while(length($dataitem->{'buf'}));
2200
0
$client->{'request'}{'response'} = undef;
2201
2202
0
_TSRReturnPrint($sentthiscall);
2203
0
say "DONE Sending Data";
2204
0
return 'RequestDone'; # not undef because keep-alive
2205
}
2206
2207
sub TrySendItem {
2208
0
0
my ($csock, $dataref) = @_;
2209
0
my $sret = send($csock, $$dataref, 0);
2210
0
0
if(! defined($sret)) {
0
2211
0
0
if($!{EAGAIN}) {
0
0
2212
#say "SEND EAGAIN\n";
2213
0
return 0;
2214
}
2215
elsif($!{ECONNRESET}) {
2216
0
print "ECONNRESET\n";
2217
}
2218
elsif($!{EPIPE}) {
2219
0
print "EPIPE\n";
2220
}
2221
else {
2222
0
print "send errno $!\n";
2223
}
2224
0
return undef;
2225
}
2226
elsif($sret) {
2227
0
substr($$dataref, 0, $sret, '');
2228
}
2229
0
return $sret;
2230
}
2231
2232
sub onHangUp {
2233
0
0
my ($client) = @_;
2234
0
return undef;
2235
}
2236
2237
sub DESTROY {
2238
0
0
my $self = shift;
2239
0
say "$$ MHFS::HTTP::Server::Client destructor: ";
2240
0
say "$$ ".'X-MHFS-CONN-ID: ' . $self->{'outheaders'}{'X-MHFS-CONN-ID'};
2241
0
0
if($self->{'sock'}) {
2242
#shutdown($self->{'sock'}, 2);
2243
0
close($self->{'sock'});
2244
}
2245
}
2246
2247
1;
2248
}
2249
2250
package MHFS::FD::Reader {
2251
1
1
8
use strict; use warnings;
1
1
2
1
19
1
5
1
3
1
37
2252
1
1
6
use feature 'say';
1
3
1
70
2253
1
1
7
use Time::HiRes qw( usleep clock_gettime CLOCK_MONOTONIC);
1
2
1
4
2254
1
1
112
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
2
1
59
2255
1
1
6
use Scalar::Util qw(looks_like_number weaken);
1
2
1
371
2256
sub new {
2257
0
0
my ($class, $process, $fd, $func) = @_;
2258
0
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'process' => $process, 'fd' => $fd, 'onReadReady' => $func);
2259
0
say "PID " . $self{'process'}{'pid'} . 'FD ' . $self{'fd'};
2260
0
weaken($self{'process'});
2261
0
return bless \%self, $class;
2262
}
2263
2264
sub onReadReady {
2265
0
0
my ($self) = @_;
2266
0
my $ret = $self->{'onReadReady'}($self->{'fd'});
2267
0
0
if($ret == 0) {
2268
0
$self->{'process'}->remove($self->{'fd'});
2269
0
return 1;
2270
}
2271
0
0
if($ret == -1) {
2272
0
return undef;
2273
}
2274
0
0
if($ret == 1) {
2275
0
return 1;
2276
}
2277
}
2278
2279
0
sub onHangUp {
2280
2281
}
2282
2283
sub DESTROY {
2284
0
0
my $self = shift;
2285
0
0
print "PID " . $self->{'process'}{'pid'} . ' ' if($self->{'process'});
2286
0
print "FD " . $self->{'fd'};
2287
0
say ' reader DESTROY called';
2288
}
2289
2290
1;
2291
}
2292
2293
package MHFS::FD::Writer {
2294
1
1
8
use strict; use warnings;
1
1
4
1
34
1
6
1
2
1
24
2295
1
1
6
use feature 'say';
1
10
1
69
2296
1
1
7
use Time::HiRes qw( usleep clock_gettime CLOCK_MONOTONIC);
1
2
1
5
2297
1
1
126
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
2
1
56
2298
1
1
9
use Scalar::Util qw(looks_like_number weaken);
1
2
1
345
2299
sub new {
2300
0
0
my ($class, $process, $fd, $func) = @_;
2301
0
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'process' => $process, 'fd' => $fd, 'onWriteReady' => $func);
2302
0
say "PID " . $self{'process'}{'pid'} . 'FD ' . $self{'fd'};
2303
0
weaken($self{'process'});
2304
0
return bless \%self, $class;
2305
}
2306
2307
sub onWriteReady {
2308
0
0
my ($self) = @_;
2309
0
my $ret = $self->{'onWriteReady'}($self->{'fd'});
2310
0
0
if($ret == 0) {
2311
0
$self->{'process'}->remove($self->{'fd'});
2312
0
return 1;
2313
}
2314
0
0
if($ret == -1) {
2315
0
return undef;
2316
}
2317
0
0
if($ret == 1) {
2318
0
return 1;
2319
}
2320
}
2321
2322
0
sub onHangUp {
2323
2324
}
2325
2326
sub DESTROY {
2327
0
0
my $self = shift;
2328
0
say "PID " . $self->{'process'}{'pid'} . " FD " . $self->{'fd'}.' writer DESTROY called';
2329
}
2330
2331
1;
2332
}
2333
2334
package MHFS::Process {
2335
1
1
8
use strict; use warnings;
1
1
2
1
17
1
4
1
2
1
36
2336
1
1
5
use feature 'say';
1
2
1
67
2337
1
1
7
use Symbol 'gensym';
1
2
1
50
2338
1
1
6
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
1
10
1
5
2339
1
1
115
use POSIX ":sys_wait_h";
1
3
1
7
2340
1
1
171
use IO::Socket::INET;
1
3
1
4
2341
1
1
521
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
1
2
1
57
2342
1
1
6
use Errno qw(EINTR EIO :POSIX);
1
2
1
258
2343
1
1
6
use Fcntl qw(:seek :mode);
1
2
1
187
2344
1
1
7
use File::stat;
1
2
1
4
2345
1
1
591
use IPC::Open3;
1
2746
1
56
2346
1
1
7
use Scalar::Util qw(looks_like_number weaken);
1
1
1
42
2347
1
1
6
use Data::Dumper;
1
2
1
37
2348
1
1
6
use Devel::Peek;
1
1
1
13
2349
2350
1
1
95
use Carp;
1
2
1
2770
2351
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
2352
2353
#my %CHILDREN;
2354
#$SIG{CHLD} = sub {
2355
# while((my $child = waitpid(-1, WNOHANG)) > 0) {
2356
# my ($wstatus, $exitcode) = ($?, $?>> 8);
2357
# if(defined $CHILDREN{$child}) {
2358
# say "PID $child reaped (func) $exitcode";
2359
# $CHILDREN{$child}->($exitcode);
2360
# # remove file handles here?
2361
# $CHILDREN{$child} = undef;
2362
# }
2363
# else {
2364
# say "PID $child reaped (No func) $exitcode";
2365
# }
2366
# }
2367
#};
2368
2369
sub _setup_handlers {
2370
0
0
my ($self, $in, $out, $err, $fddispatch, $handlesettings) = @_;
2371
0
my $pid = $self->{'pid'};
2372
0
my $evp = $self->{'evp'};
2373
2374
0
0
if($fddispatch->{'SIGCHLD'}) {
2375
0
say "PID $pid custom SIGCHLD handler";
2376
#$CHILDREN{$pid} = $fddispatch->{'SIGCHLD'};
2377
0
$evp->register_child($pid, $fddispatch->{'SIGCHLD'});
2378
}
2379
0
0
if($fddispatch->{'STDIN'}) {
2380
0
$self->{'fd'}{'stdin'} = MHFS::FD::Writer->new($self, $in, $fddispatch->{'STDIN'});
2381
0
$evp->set($in, $self->{'fd'}{'stdin'}, POLLOUT | MHFS::EventLoop::Poll->ALWAYSMASK);
2382
}
2383
else {
2384
0
$self->{'fd'}{'stdin'}{'fd'} = $in;
2385
}
2386
0
0
if($fddispatch->{'STDOUT'}) {
2387
0
$self->{'fd'}{'stdout'} = MHFS::FD::Reader->new($self, $out, $fddispatch->{'STDOUT'});
2388
0
$evp->set($out, $self->{'fd'}{'stdout'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK());
2389
}
2390
else {
2391
0
$self->{'fd'}{'stdout'}{'fd'} = $out;
2392
}
2393
0
0
if($fddispatch->{'STDERR'}) {
2394
0
$self->{'fd'}{'stderr'} = MHFS::FD::Reader->new($self, $err, $fddispatch->{'STDERR'});
2395
0
$evp->set($err, $self->{'fd'}{'stderr'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK);
2396
}
2397
else {
2398
0
$self->{'fd'}{'stderr'}{'fd'} = $err;
2399
}
2400
2401
0
0
if($handlesettings->{'O_NONBLOCK'}) {
2402
0
my $flags = 0;
2403
# stderr
2404
0
0
(0 == fcntl($err, Fcntl::F_GETFL, $flags)) or die;#return undef;
2405
0
$flags |= Fcntl::O_NONBLOCK;
2406
0
0
(0 == fcntl($err, Fcntl::F_SETFL, $flags)) or die;#return undef;
2407
# stdout
2408
0
0
(0 == fcntl($out, Fcntl::F_GETFL, $flags)) or die;#return undef;
2409
0
$flags |= Fcntl::O_NONBLOCK;
2410
0
0
(0 == fcntl($out, Fcntl::F_SETFL, $flags)) or die;#return undef;
2411
# stdin
2412
0
0
defined($in->blocking(0)) or die($!);
2413
#(0 == fcntl($in, Fcntl::F_GETFL, $flags)) or die("$!");#return undef;
2414
#$flags |= Fcntl::O_NONBLOCK;
2415
#(0 == fcntl($in, Fcntl::F_SETFL, $flags)) or die;#return undef;
2416
0
return $self;
2417
}
2418
}
2419
2420
sub sigkill {
2421
0
0
my ($self, $cb) = @_;
2422
0
0
if($cb) {
2423
0
$self->{'evp'}{'children'}{$self->{'pid'}} = $cb;
2424
}
2425
0
kill('KILL', $self->{'pid'});
2426
}
2427
2428
sub stopSTDOUT {
2429
0
0
my ($self) = @_;
2430
0
$self->{'evp'}->set($self->{'fd'}{'stdout'}{'fd'}, $self->{'fd'}{'stdout'}, MHFS::EventLoop::Poll->ALWAYSMASK);
2431
}
2432
2433
sub resumeSTDOUT {
2434
0
0
my ($self) = @_;
2435
0
$self->{'evp'}->set($self->{'fd'}{'stdout'}{'fd'}, $self->{'fd'}{'stdout'}, POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK);
2436
}
2437
2438
sub new {
2439
0
0
my ($class, $torun, $evp, $fddispatch, $handlesettings, $env) = @_;
2440
0
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'evp' => $evp);
2441
2442
2443
0
my %oldenvvars;
2444
0
0
if($env) {
2445
0
foreach my $key(keys %{$env}) {
0
2446
# save current value
2447
0
$oldenvvars{$key} = $ENV{$key};
2448
# set new value
2449
0
$ENV{$key} = $env->{$key};
2450
0
0
my $oldval = $oldenvvars{$key} // '{undef}';
2451
0
0
my $newval = $env->{$key} // '{undef}';
2452
0
say "Changed \$ENV{$key} from $oldval to $newval";
2453
}
2454
}
2455
2456
0
my ($pid, $in, $out, $err);
2457
0
eval{ $pid = open3($in, $out, $err = gensym, @$torun); };
0
2458
0
0
if($@) {
2459
0
say "BAD process";
2460
0
return undef;
2461
}
2462
0
$self{'pid'} = $pid;
2463
0
say 'PID '. $pid . ' NEW PROCESS: ' . $torun->[0];
2464
0
0
if($env) {
2465
# restore environment
2466
0
foreach my $key(keys %oldenvvars) {
2467
0
$ENV{$key} = $oldenvvars{$key};
2468
0
0
my $oldval = $env->{$key} // '{undef}';
2469
0
0
my $newval = $oldenvvars{$key} // '{undef}';
2470
0
say "Restored \$ENV{$key} from $oldval to $newval";
2471
}
2472
}
2473
0
_setup_handlers(\%self, $in, $out, $err, $fddispatch, $handlesettings);
2474
0
return bless \%self, $class;
2475
}
2476
2477
sub _new_ex {
2478
0
0
my ($make_process, $make_process_args, $context) = @_;
2479
0
my $process;
2480
0
$context->{'stdout'} = '';
2481
0
$context->{'stderr'} = '';
2482
my $prochandlers = {
2483
'STDOUT' => sub {
2484
0
0
my ($handle) = @_;
2485
0
my $buf;
2486
0
while(read($handle, $buf, 4096)) {
2487
0
$context->{'stdout'} .= $buf;
2488
}
2489
0
0
if($context->{'on_stdout_data'}) {
2490
0
$context->{'on_stdout_data'}->($context);
2491
}
2492
0
return 1;
2493
},
2494
'STDERR' => sub {
2495
0
0
my ($handle) = @_;
2496
0
my $buf;
2497
0
while(read($handle, $buf, 4096)) {
2498
0
$context->{'stderr'} .= $buf;
2499
}
2500
0
return 1;
2501
},
2502
'SIGCHLD' => sub {
2503
0
0
my $obuf;
2504
0
my $handle = $process->{'fd'}{'stdout'}{'fd'};
2505
0
while(read($handle, $obuf, 100000)) {
2506
0
$context->{'stdout'} .= $obuf;
2507
0
say "stdout sigchld read";
2508
}
2509
0
my $ebuf;
2510
0
$handle = $process->{'fd'}{'stderr'}{'fd'};
2511
0
while(read($handle, $ebuf, 100000)) {
2512
0
$context->{'stderr'} .= $ebuf;
2513
0
say "stderr sigchld read";
2514
}
2515
0
0
if($context->{'on_stdout_data'}) {
2516
0
$context->{'on_stdout_data'}->($context);
2517
}
2518
0
$context->{'at_exit'}->($context);
2519
},
2520
0
};
2521
2522
0
0
if($context->{'input'}) {
2523
$prochandlers->{'STDIN'} = sub {
2524
0
0
my ($fh) = @_;
2525
0
while(1) {
2526
0
my $curbuf = $context->{'curbuf'};
2527
0
0
if($curbuf) {
2528
0
my $rv = syswrite($fh, $curbuf, length($curbuf));
2529
0
0
if(!defined($rv)) {
0
2530
0
0
if(! $!{EAGAIN}) {
2531
0
say "Critical write error";
2532
0
return -1;
2533
}
2534
0
return 1;
2535
}
2536
elsif($rv != length($curbuf)) {
2537
0
substr($context->{'curbuf'}, 0, $rv, '');
2538
0
return 1;
2539
}
2540
else {
2541
0
say "wrote all";
2542
}
2543
}
2544
0
$context->{'curbuf'} = $context->{'input'}->($context);
2545
0
0
if(! defined $context->{'curbuf'}) {
2546
0
return 0;
2547
}
2548
}
2549
0
};
2550
}
2551
2552
0
$process = $make_process->($make_process_args, $prochandlers, {'O_NONBLOCK' => 1});
2553
0
return $process;
2554
}
2555
2556
# launch a command process with poll handlers
2557
sub _new_cmd {
2558
0
0
my ($mpa, $prochandlers, $handlesettings) = @_;
2559
0
return $mpa->{'class'}->new($mpa->{'cmd'}, $mpa->{'evp'}, $prochandlers, $handlesettings);
2560
}
2561
2562
# launch a command process
2563
sub new_cmd_process {
2564
0
0
my ($class, $evp, $cmd, $context) = @_;
2565
0
my $mpa = {'class' => $class, 'evp' => $evp, 'cmd' => $cmd};
2566
0
return _new_ex(\&_new_cmd, $mpa, $context);
2567
}
2568
2569
# subset of command process, just need the data on SIGCHLD
2570
sub new_output_process {
2571
0
0
my ($class, $evp, $cmd, $handler) = @_;
2572
2573
return new_cmd_process($class, $evp, $cmd, {
2574
'at_exit' => sub {
2575
0
0
my ($context) = @_;
2576
0
say 'run handler';
2577
0
$handler->($context->{'stdout'}, $context->{'stderr'});
2578
}
2579
0
});
2580
}
2581
2582
sub new_io_process {
2583
0
0
my ($class, $evp, $cmd, $handler, $inputdata) = @_;
2584
my $ctx = {
2585
'at_exit' => sub {
2586
0
0
my ($context) = @_;
2587
0
say 'run handler';
2588
0
$handler->($context->{'stdout'}, $context->{'stderr'});
2589
}
2590
0
};
2591
0
0
if(defined $inputdata) {
2592
0
$ctx->{'curbuf'} = $inputdata;
2593
$ctx->{'input'} = sub {
2594
0
0
say "all written";
2595
0
return undef;
2596
0
};
2597
}
2598
0
return new_cmd_process($class, $evp, $cmd, $ctx);
2599
}
2600
2601
# launch a process without a new exe with poll handlers
2602
sub _new_child {
2603
0
0
my ($mpa, $prochandlers, $handlesettings) = @_;
2604
2605
0
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'evp' => $mpa->{'evp'});
2606
# inreader/inwriter is the parent to child data channel
2607
# outreader/outwriter is the child to parent data channel
2608
# errreader/errwriter is the child to parent log channel
2609
0
0
pipe(my $inreader, my $inwriter) or die("pipe failed $!");
2610
0
0
pipe(my $outreader, my $outwriter) or die("pipe failed $!");
2611
0
0
pipe(my $errreader, my $errwriter) or die("pipe failed $!");
2612
# the childs stderr will be UTF-8 text
2613
0
binmode($errreader, ':encoding(UTF-8)');
2614
0
my $pid = fork();
2615
0
0
if($pid == 0) {
2616
0
close($inwriter);
2617
0
close($outreader);
2618
0
close($errreader);
2619
0
0
open(STDIN, "<&", $inreader) or die("Can't dup \$inreader to STDIN");
2620
0
0
open(STDOUT, ">&", $errwriter) or die("Can't dup \$errwriter to STDOUT");
2621
0
0
open(STDERR, ">&", $errwriter) or die("Can't dup \$errwriter to STDERR");
2622
0
$mpa->{'func'}->($outwriter);
2623
0
exit 0;
2624
}
2625
0
close($inreader);
2626
0
close($outwriter);
2627
0
close($errwriter);
2628
0
$self{'pid'} = $pid;
2629
0
say 'PID '. $pid . ' NEW CHILD';
2630
0
_setup_handlers(\%self, $inwriter, $outreader, $errreader, $prochandlers, $handlesettings);
2631
0
return bless \%self, $mpa->{'class'};
2632
}
2633
2634
sub cmd_to_sock {
2635
0
0
my ($name, $cmd, $sockfh) = @_;
2636
0
0
if(fork() == 0) {
2637
0
0
open(STDOUT, ">&", $sockfh) or die("Can't dup \$sockfh to STDOUT");
2638
0
exec(@$cmd);
2639
0
die;
2640
}
2641
0
close($sockfh);
2642
}
2643
2644
# launch a process without a new exe with just sigchld handler
2645
sub new_output_child {
2646
0
0
my ($class, $evp, $func, $handler) = @_;
2647
0
my $mpa = {'class' => $class, 'evp' => $evp, 'func' => $func};
2648
return _new_ex(\&_new_child, $mpa, {
2649
'at_exit' => sub {
2650
0
0
my ($context) = @_;
2651
0
$handler->($context->{'stdout'}, $context->{'stderr'});
2652
}
2653
0
});
2654
}
2655
2656
sub remove {
2657
0
0
my ($self, $fd) = @_;
2658
0
$self->{'evp'}->remove($fd);
2659
0
say "poll has " . scalar ( $self->{'evp'}{'poll'}->handles) . " handles";
2660
0
foreach my $key (keys %{$self->{'fd'}}) {
0
2661
0
0
0
if(defined($self->{'fd'}{$key}{'fd'}) && ($fd == $self->{'fd'}{$key}{'fd'})) {
2662
0
$self->{'fd'}{$key} = undef;
2663
0
last;
2664
}
2665
}
2666
}
2667
2668
2669
sub DESTROY {
2670
0
0
my $self = shift;
2671
0
say "PID " . $self->{'pid'} . ' DESTROY called';
2672
0
foreach my $key (keys %{$self->{'fd'}}) {
0
2673
0
0
if(defined($self->{'fd'}{$key}{'fd'})) {
2674
#Dump($self->{'fd'}{$key});
2675
0
$self->{'evp'}->remove($self->{'fd'}{$key}{'fd'});
2676
0
$self->{'fd'}{$key} = undef;
2677
}
2678
}
2679
}
2680
2681
1;
2682
}
2683
2684
package MHFS::Settings {
2685
1
1
9
use strict; use warnings;
1
1
2
1
30
1
6
1
2
1
38
2686
1
1
5
use feature 'say';
1
3
1
76
2687
1
1
7
use Scalar::Util qw(reftype);
1
2
1
56
2688
1
1
7
use File::Basename;
1
2
1
75
2689
1
1
6
use Digest::MD5 qw(md5_hex);
1
2
1
70
2690
1
1
712
use Storable qw(freeze);
1
3237
1
64
2691
1
1
7
use Cwd qw(abs_path);
1
4
1
51
2692
1
1
549
use File::ShareDir qw(dist_dir);
1
27193
1
66
2693
1
1
9
use File::Path qw(make_path);
1
1
1
50
2694
1
1
480
use File::Spec::Functions qw(rel2abs);
1
884
1
2188
2695
2696
MHFS::Util->import();
2697
2698
sub write_settings_file {
2699
0
0
my ($SETTINGS, $filepath) = @_;
2700
0
my $indentcnst = 4;
2701
0
my $indentspace = '';
2702
0
my $settingscontents = "#!/usr/bin/perl\nuse strict; use warnings;\n\nmy \$SETTINGS = ";
2703
2704
# we only encode SCALARS. Loop through expanding HASH and ARRAY refs into SCALARS
2705
0
my @values = ($SETTINGS);
2706
0
while(@values) {
2707
0
my $value = shift @values;
2708
0
my $type = reftype($value);
2709
0
0
say "value: $value type: " . ($type // 'undef');
2710
0
my $raw;
2711
my $noindent;
2712
0
0
if(! defined $type) {
2713
0
0
if(defined $value) {
2714
# process lead control code if provided
2715
0
$raw = ($value eq '__raw');
2716
0
$noindent = ($value eq '__noindent');
2717
0
0
0
if($raw || $noindent) {
2718
0
$value = shift @values;
2719
}
2720
}
2721
2722
0
0
if(! defined $value) {
0
2723
0
$raw = 1;
2724
0
$value = 'undef';
2725
0
$type = 'SCALAR';
2726
}
2727
elsif($value eq '__indent-') {
2728
0
substr($indentspace, -4, 4, '');
2729
# don't actually encode anything
2730
0
$value = '';
2731
0
$type = 'NOP';
2732
}
2733
else {
2734
0
0
$type = reftype($value) // 'SCALAR';
2735
}
2736
}
2737
2738
0
say "v2: $value type $type";
2739
0
0
if($type eq 'NOP') {
2740
0
next;
2741
}
2742
2743
0
0
$settingscontents .= $indentspace if(! $noindent);
2744
0
0
if($type eq 'SCALAR') {
0
0
2745
# encode the value
2746
0
0
if(! $raw) {
2747
0
$value =~ s/'/\\'/g;
2748
0
$value = "'".$value."'";
2749
}
2750
2751
# add the value to the buffer
2752
0
$settingscontents .= $value;
2753
0
0
$settingscontents .= ",\n" if(! $raw);
2754
}
2755
elsif($type eq 'HASH') {
2756
0
$settingscontents .= "{\n";
2757
0
$indentspace .= (' ' x $indentcnst);
2758
0
my @toprepend;
2759
0
foreach my $key (keys %{$value}) {
0
2760
0
push @toprepend, '__raw', "'$key' => ", '__noindent', $value->{$key};
2761
}
2762
0
push @toprepend, '__indent-', '__raw', "},\n";
2763
0
unshift(@values, @toprepend);
2764
}
2765
elsif($type eq 'ARRAY') {
2766
0
$settingscontents .= "[\n";
2767
0
$indentspace .= (' ' x $indentcnst);
2768
0
my @toprepend = @{$value};
0
2769
0
push @toprepend, '__indent-', '__raw', "],\n";
2770
0
unshift(@values, @toprepend);
2771
}
2772
else {
2773
0
die("Unknown type: $type");
2774
}
2775
}
2776
0
chop $settingscontents;
2777
0
chop $settingscontents;
2778
0
$settingscontents .= ";\n\n\$SETTINGS;\n";
2779
0
say "making settings folder $filepath";
2780
0
make_path(dirname($filepath));
2781
0
write_file($filepath, $settingscontents);
2782
}
2783
2784
sub calc_source_id {
2785
0
0
my ($source) = @_;
2786
0
0
if($source->{'type'} ne 'local') {
2787
0
say "only local sources supported right now";
2788
0
return undef;
2789
}
2790
0
return substr(md5_hex('local:'.$source->{folder}), 0, 8);
2791
}
2792
2793
sub load {
2794
0
0
my ($launchsettings) = @_;
2795
0
my $scriptpath = abs_path(__FILE__);
2796
2797
# settings are loaded with the following precedence
2798
# $launchsettings (@ARGV) > settings.pl > General environment vars
2799
# Directory preference goes from declared to defaults and specific to general:
2800
# For example $CFGDIR > $XDG_CONFIG_HOME > $XDG_CONFIG_DIRS > $FALLBACK_DATA_ROOT
2801
2802
# load in the launchsettings
2803
0
my ($CFGDIR, $APPDIR, $FALLBACK_DATA_ROOT);
2804
0
0
if(exists $launchsettings->{CFGDIR}) {
2805
0
make_path($launchsettings->{CFGDIR});
2806
0
$CFGDIR = $launchsettings->{CFGDIR};
2807
}
2808
0
0
if(exists $launchsettings->{APPDIR}) {
2809
0
0
-d $launchsettings->{APPDIR} or die("Bad APPDIR provided");
2810
0
$APPDIR = $launchsettings->{APPDIR};
2811
}
2812
0
0
if(exists $launchsettings->{FALLBACK_DATA_ROOT}) {
2813
0
make_path($launchsettings->{FALLBACK_DATA_ROOT});
2814
0
$FALLBACK_DATA_ROOT = $launchsettings->{FALLBACK_DATA_ROOT};
2815
}
2816
2817
# determine the settings dir
2818
0
0
if(! $CFGDIR){
2819
0
0
my $cfg_fallback = $FALLBACK_DATA_ROOT // $ENV{'HOME'};
2820
0
0
0
$cfg_fallback //= ($ENV{APPDATA}.'/mhfs') if($ENV{APPDATA}); # Windows
2821
# set the settings dir to the first that exists of $XDG_CONFIG_HOME and $XDG_CONFIG_DIRS
2822
# https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html
2823
0
my $XDG_CONFIG_HOME = $ENV{'XDG_CONFIG_HOME'};
2824
0
0
0
$XDG_CONFIG_HOME //= ($cfg_fallback . '/.config') if($cfg_fallback);
2825
0
my @configdirs;
2826
0
0
push @configdirs, $XDG_CONFIG_HOME if($XDG_CONFIG_HOME);
2827
0
0
my $XDG_CONFIG_DIRS = $ENV{'XDG_CONFIG_DIRS'} || '/etc/xdg';
2828
0
push @configdirs, split(':', $XDG_CONFIG_DIRS);
2829
0
foreach my $cfgdir (@configdirs) {
2830
0
0
if(-d "$cfgdir/mhfs") {
2831
0
$CFGDIR = "$cfgdir/mhfs";
2832
0
last;
2833
}
2834
}
2835
0
0
0
$CFGDIR //= ($XDG_CONFIG_HOME.'/mhfs') if($XDG_CONFIG_HOME);
2836
0
0
defined($CFGDIR) or die("Failed to find valid candidate for \$CFGDIR");
2837
}
2838
0
$CFGDIR = rel2abs($CFGDIR);
2839
2840
# load from the settings file
2841
0
my $SETTINGS_FILE = rel2abs($CFGDIR . '/settings.pl');
2842
0
my $SETTINGS = do ($SETTINGS_FILE);
2843
0
0
if(! $SETTINGS) {
2844
0
0
die "Error parsing settingsfile: $@" if($@);
2845
0
0
die "Cannot read settingsfile: $!" if(-e $SETTINGS_FILE);
2846
0
warn("No settings file found, using default settings");
2847
0
$SETTINGS = {};
2848
}
2849
2850
# load defaults for unset values
2851
0
0
$SETTINGS->{'HOST'} ||= "127.0.0.1";
2852
0
0
$SETTINGS->{'PORT'} ||= 8000;
2853
2854
0
0
$SETTINGS->{'ALLOWED_REMOTEIP_HOSTS'} ||= [
2855
['127.0.0.1'],
2856
];
2857
2858
# write the default settings
2859
0
0
if(! -f $SETTINGS_FILE) {
2860
0
write_settings_file($SETTINGS, $SETTINGS_FILE);
2861
}
2862
0
$SETTINGS->{'CFGDIR'} = $CFGDIR;
2863
0
0
$SETTINGS->{flush} = $launchsettings->{flush} if(exists $launchsettings->{flush});
2864
2865
# locate files based on appdir
2866
0
0
$APPDIR ||= $SETTINGS->{'APPDIR'} || dist_dir('App-MHFS');
0
2867
0
$APPDIR = abs_path($APPDIR);
2868
0
say __PACKAGE__.": using APPDIR " . $APPDIR;
2869
0
$SETTINGS->{'APPDIR'} = $APPDIR;
2870
2871
# determine the fallback data root
2872
0
0
$FALLBACK_DATA_ROOT ||= $SETTINGS->{'FALLBACK_DATA_ROOT'} || $ENV{'HOME'};
0
2873
0
0
0
$FALLBACK_DATA_ROOT ||= ($ENV{APPDATA}.'/mhfs') if($ENV{APPDATA}); # Windows
2874
0
0
if($FALLBACK_DATA_ROOT) {
2875
0
$FALLBACK_DATA_ROOT = abs_path($FALLBACK_DATA_ROOT);
2876
}
2877
# determine the allowed remoteip host combos. only ipv4 now sorry
2878
0
$SETTINGS->{'ARIPHOSTS_PARSED'} = [];
2879
0
foreach my $rule (@{$SETTINGS->{'ALLOWED_REMOTEIP_HOSTS'}}) {
0
2880
# parse IPv4 with optional CIDR
2881
0
0
$rule->[0] =~ /^([^\/]+)(?:\/(\d{1,2}))?$/ or die("Invalid rule: " . $rule->[0]);
2882
0
0
my $ipstr = $1; my $cidr = $2 // 32;
0
2883
0
my $ip = MHFS::Util::ParseIPv4($ipstr);
2884
0
0
defined($ip) or die("Invalid rule: " . $rule->[0]);
2885
0
0
0
$cidr >= 0 && $cidr <= 32 or die("Invalid rule: " . $rule->[0]);
2886
0
my $mask = (0xFFFFFFFF << (32-$cidr)) & 0xFFFFFFFF;
2887
0
my %ariphost = (
2888
'ip' => $ip,
2889
'subnetmask' => $mask
2890
);
2891
# store the server hostname if verification is required for this rule
2892
0
0
$ariphost{'hostname'} = $rule->[1] if($rule->[1]);
2893
# store overriding absurl from this host if provided
2894
0
0
if($rule->[2]) {
2895
0
my $absurl = $rule->[2];
2896
0
0
chop $absurl if(index($absurl, '/', length($absurl)-1) != -1);
2897
0
$ariphost{'absurl'} = $absurl;
2898
}
2899
# store whether to trust connections with this host
2900
0
0
if($rule->[3]) {
2901
0
$ariphost{'X-MHFS-PROXY-KEY'} = $rule->[3];
2902
}
2903
0
push @{ $SETTINGS->{'ARIPHOSTS_PARSED'}}, \%ariphost;
0
2904
}
2905
2906
0
0
if( ! $SETTINGS->{'DOCUMENTROOT'}) {
2907
0
$SETTINGS->{'DOCUMENTROOT'} = "$APPDIR/public_html";
2908
}
2909
0
0
$SETTINGS->{'XSEND'} //= 0;
2910
0
my $tmpdir = $SETTINGS->{'TMPDIR'};
2911
0
0
0
$tmpdir ||= ($ENV{'XDG_CACHE_HOME'}.'/mhfs') if($ENV{'XDG_CACHE_HOME'});
2912
0
0
0
$tmpdir ||= "$FALLBACK_DATA_ROOT/.cache/mhfs" if($FALLBACK_DATA_ROOT);
2913
0
0
defined($tmpdir) or die("Failed to find valid candidate for \$tmpdir");
2914
0
delete $SETTINGS->{'TMPDIR'}; # Use specific temp dir instead
2915
0
0
if(!$SETTINGS->{'RUNTIME_DIR'} ) {
2916
0
my $RUNTIMEDIR = $ENV{'XDG_RUNTIME_DIR'};
2917
0
0
if(! $RUNTIMEDIR ) {
2918
0
$RUNTIMEDIR = $tmpdir;
2919
0
warn("XDG_RUNTIME_DIR not defined!, using $RUNTIMEDIR instead");
2920
}
2921
0
$SETTINGS->{'RUNTIME_DIR'} = $RUNTIMEDIR.'/mhfs';
2922
}
2923
0
my $datadir = $SETTINGS->{'DATADIR'};
2924
0
0
0
$datadir ||= ($ENV{'XDG_DATA_HOME'}.'/mhfs') if($ENV{'XDG_DATA_HOME'});
2925
0
0
0
$datadir ||= "$FALLBACK_DATA_ROOT/.local/share/mhfs" if($FALLBACK_DATA_ROOT);
2926
0
0
defined($datadir) or die("Failed to find valid candidate for \$datadir");
2927
0
$SETTINGS->{'DATADIR'} = $datadir;
2928
0
0
$SETTINGS->{'MHFS_TRACKER_TORRENT_DIR'} ||= $SETTINGS->{'DATADIR'}.'/torrent';
2929
0
0
$SETTINGS->{'VIDEO_TMPDIR'} ||= $tmpdir.'/video';
2930
0
0
$SETTINGS->{'MUSIC_TMPDIR'} ||= $tmpdir.'/music';
2931
0
0
$SETTINGS->{'GENERIC_TMPDIR'} ||= $tmpdir.'/tmp';
2932
0
0
$SETTINGS->{'SECRET_TMPDIR'} ||= $tmpdir.'/secret';
2933
$SETTINGS->{'MEDIALIBRARIES'}{'movies'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/movies",
2934
$SETTINGS->{'MEDIALIBRARIES'}{'tv'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/tv",
2935
0
0
$SETTINGS->{'MEDIALIBRARIES'}{'music'} ||= $SETTINGS->{'DOCUMENTROOT'} . "/media/music",
0
0
2936
my %sources;
2937
0
my %mediasources;
2938
0
foreach my $lib ('movies', 'tv', 'music') {
2939
0
my $srcs = $SETTINGS->{'MEDIALIBRARIES'}{$lib};
2940
0
0
if(ref($srcs) ne 'ARRAY') {
2941
0
$srcs = [$srcs];
2942
}
2943
0
my @subsrcs;
2944
0
foreach my $source (@$srcs) {
2945
0
my $stype = ref($source);
2946
0
my $tohash = $source;
2947
0
0
if($stype ne 'HASH') {
2948
0
0
if($stype ne '') {
2949
0
say __PACKAGE__.": skipping source";
2950
0
next;
2951
}
2952
0
$tohash = {type => 'local', folder => $source};
2953
}
2954
0
my $sid = calc_source_id($tohash);
2955
0
$sources{$sid} = $tohash;
2956
0
push @subsrcs, $sid;
2957
}
2958
0
$mediasources{$lib} = \@subsrcs;
2959
}
2960
0
$SETTINGS->{'MEDIASOURCES'} = \%mediasources;
2961
2962
0
my $videotmpdirsrc = {type => 'local', folder => $SETTINGS->{'VIDEO_TMPDIR'}};
2963
0
my $vtempsrcid = calc_source_id($videotmpdirsrc);
2964
0
$sources{$vtempsrcid} = $videotmpdirsrc;
2965
0
$SETTINGS->{'VIDEO_TMPDIR_QS'} = 'sid='.$vtempsrcid;
2966
0
$SETTINGS->{'SOURCES'} = \%sources;
2967
2968
0
0
$SETTINGS->{'BINDIR'} ||= $APPDIR . '/bin';
2969
0
0
$SETTINGS->{'DOCDIR'} ||= $APPDIR . '/doc';
2970
2971
# specify timeouts in seconds
2972
0
0
$SETTINGS->{'TIMEOUT'} ||= 75;
2973
# time to recieve the requestline and headers before closing the conn
2974
0
0
$SETTINGS->{'recvrequestimeout'} ||= $SETTINGS->{'TIMEOUT'};
2975
# maximum time allowed between sends
2976
0
0
$SETTINGS->{'sendresponsetimeout'} ||= $SETTINGS->{'TIMEOUT'};
2977
2978
0
0
0
$SETTINGS->{'Torrent'}{'pyroscope'} ||= $FALLBACK_DATA_ROOT .'/.local/pyroscope' if($FALLBACK_DATA_ROOT);
2979
2980
0
return $SETTINGS;
2981
}
2982
2983
1;
2984
};
2985
2986
package MHFS::BitTorrent::Bencoding {
2987
1
1
9
use strict; use warnings;
1
1
3
1
21
1
4
1
3
1
45
2988
1
1
8
use Exporter 'import';
1
2
1
45
2989
our @EXPORT = ('bencode', 'bdecode');
2990
1
1
6
use feature 'say';
1
2
1
816
2991
2992
# a node is an array with the first element being the type, followed by the value(s)
2993
# ('int', iv) - integer node, MUST have one integer value, bencoded as iIVe
2994
# ('bstr', bytestring) - byte string node, MUST have one bytestring value, bencoded as bytestringLength:bytestring where bytestringLength is the length as ASCII numbers
2995
# ('l', values) - list node, MAY have one or more values of type int, bstr, list, and dict bencoded as lVALUESe
2996
# ('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
2997
# ('null', value) - null node, MAY have one value, used internally by bdecode to avoid dealing with the base case of no parent
2998
# ('e') - end node, MUST NOT have ANY values, used internally by bencode to handle writing list/dict end
2999
3000
sub bencode {
3001
0
0
my ($node) = @_;
3002
0
my @toenc = ($node);
3003
0
my $output;
3004
3005
0
while(my $node = shift @toenc) {
3006
0
my $type = $node->[0];
3007
0
0
0
if(($type eq 'd') || ($type eq 'l')) {
0
0
0
3008
0
$output .= $type;
3009
0
my @nextitems = @{$node};
0
3010
0
shift @nextitems;
3011
0
push @nextitems, ['e'];
3012
0
unshift @toenc, @nextitems;
3013
}
3014
elsif($type eq 'bstr') {
3015
0
$output .= sprintf("%u:%s", length($node->[1]), $node->[1]);
3016
}
3017
elsif($type eq 'int') {
3018
0
$output .= 'i'.$node->[1].'e';
3019
}
3020
elsif($type eq 'e') {
3021
0
$output .= 'e';
3022
}
3023
else {
3024
0
return undef;
3025
}
3026
}
3027
3028
0
return $output;
3029
}
3030
3031
sub bdecode {
3032
0
0
my ($contents, $foffset) = @_;
3033
0
my @headnode = ('null');
3034
0
my @nodestack = (\@headnode);
3035
0
my $startoffset = $foffset;
3036
3037
0
while(1) {
3038
# a bstr is always valid as it can be a dict key
3039
0
0
0
if(substr($$contents, $foffset) =~ /^(0|[1-9][0-9]*):/) {
0
0
0
0
3040
0
my $count = $1;
3041
0
$foffset += length($count)+1;
3042
0
my $bstr = substr($$contents, $foffset, $count);
3043
0
my $node = ['bstr', $bstr];
3044
0
$foffset += $count;
3045
0
push @{$nodestack[-1]}, $node;
0
3046
}
3047
elsif((substr($$contents, $foffset, 1) eq 'e') &&
3048
(($nodestack[-1][0] eq 'l') ||
3049
(($nodestack[-1][0] eq 'd') &&((scalar(@{$nodestack[-1]}) % 2) == 1)))) {
3050
0
pop @nodestack;
3051
0
$foffset++;
3052
}
3053
0
elsif(($nodestack[-1][0] ne 'd') || ((scalar(@{$nodestack[-1]}) % 2) == 0)) {
3054
0
my $firstchar = substr($$contents, $foffset++, 1);
3055
0
0
0
if(($firstchar eq 'd') || ($firstchar eq 'l')) {
0
3056
0
my $node = [$firstchar];
3057
0
push @{$nodestack[-1]}, $node;
0
3058
0
push @nodestack, $node;
3059
}
3060
elsif(substr($$contents, $foffset-1) =~ /^i(0|\-?[1-9][0-9]*)e/) {
3061
0
my $node = ['int', $1];
3062
0
$foffset += length($1)+1;
3063
0
push @{$nodestack[-1]}, $node;
0
3064
}
3065
else {
3066
0
say "bad elm $firstchar $foffset";
3067
0
return undef;
3068
}
3069
}
3070
else {
3071
0
say "bad elm $foffset";
3072
0
return undef;
3073
}
3074
3075
0
0
if(scalar(@nodestack) == 1) {
3076
0
return [$headnode[1], $foffset-$startoffset];
3077
}
3078
}
3079
}
3080
3081
1;
3082
}
3083
3084
package MHFS::BitTorrent::Metainfo {
3085
1
1
8
use strict;
1
3
1
57
3086
1
1
6
use warnings;
1
3
1
43
3087
1
1
8
use feature 'say';
1
2
1
62
3088
1
1
536
use Digest::SHA qw(sha1);
1
3111
1
96
3089
MHFS::BitTorrent::Bencoding->import();
3090
1
1
8
use Data::Dumper;
1
3
1
966
3091
3092
sub Parse {
3093
0
0
my ($srcdata) = @_;
3094
0
my $tree = bdecode($srcdata, 0);
3095
0
0
return undef if(! $tree);
3096
0
return MHFS::BitTorrent::Metainfo->_new($tree->[0]);
3097
}
3098
3099
sub mktor {
3100
0
0
my ($evp, $params, $cb) = @_;
3101
0
my $process;
3102
0
my @cmd = ('mktor', @$params);
3103
$process = MHFS::Process->new_output_process($evp, \@cmd, sub {
3104
0
0
my ($output, $error) = @_;
3105
0
chomp $output;
3106
0
say 'mktor output: ' . $output;
3107
0
$cb->($output);
3108
0
});
3109
0
return $process;
3110
}
3111
3112
sub Create {
3113
0
0
my ($evp, $opt, $cb) = @_;
3114
3115
0
0
0
if((! exists $opt->{src}) || (! exists $opt->{dest_metafile}) || (! exists $opt->{tracker})) {
0
3116
0
say "MHFS::BitTorrent::Metainfo::Create - Invalid opts";
3117
0
$cb->(undef);
3118
0
return;
3119
}
3120
3121
0
my @params;
3122
0
0
push @params, '-p' if($opt->{private});
3123
0
push @params, ('-o', $opt->{dest_metafile});
3124
0
push @params, $opt->{src};
3125
0
push @params, $opt->{tracker};
3126
0
print "$_ " foreach @params;
3127
0
print "\n";
3128
3129
0
mktor($evp, \@params, $cb);
3130
}
3131
3132
sub InfohashAsHex {
3133
0
0
my ($self) = @_;
3134
0
return uc(unpack('H*', $self->{'infohash'}));
3135
}
3136
3137
sub _bdictfind {
3138
0
0
my ($node, $keys, $valuetype) = @_;
3139
0
NEXTKEY: foreach my $key (@{$keys}) {
0
3140
0
0
if($node->[0] ne 'd') {
3141
0
say "cannot search non dictionary";
3142
0
return undef;
3143
}
3144
0
for(my $i = 1; $i < scalar(@{$node}); $i+=2) {
0
3145
0
0
if($node->[$i][1] eq $key) {
3146
0
$node = $node->[$i+1];
3147
0
last NEXTKEY;
3148
}
3149
}
3150
0
say "failed to find key $key";
3151
0
return undef;
3152
}
3153
0
0
0
if(($valuetype) && ($node->[0] ne $valuetype)) {
3154
0
say "node has wrong type, expected $valuetype got ". $node->[0];
3155
0
return undef;
3156
}
3157
0
return $node;
3158
}
3159
3160
sub _bdictgetkeys {
3161
0
0
my ($node) = @_;
3162
0
0
if($node->[0] ne 'd') {
3163
0
say "cannot search non dictionary";
3164
0
return undef;
3165
}
3166
0
my @keys;
3167
0
for(my $i = 1; $i < scalar(@{$node}); $i+=2) {
0
3168
0
push @keys, $node->[$i][1];
3169
}
3170
0
return \@keys;
3171
}
3172
3173
sub _new {
3174
0
0
my ($class, $tree) = @_;
3175
0
my $infodata = _bdictfind($tree, ['info'], 'd');
3176
0
0
return undef if(! $infodata);
3177
0
my %self = (tree => $tree, 'infohash' => sha1(bencode($infodata)));
3178
0
bless \%self, $class;
3179
0
return \%self;
3180
}
3181
3182
1;
3183
}
3184
3185
package MHFS::FS {
3186
1
1
9
use strict; use warnings;
1
1
2
1
34
1
6
1
2
1
49
3187
1
1
6
use feature 'say';
1
2
1
86
3188
1
1
6
use Cwd qw(abs_path);
1
3
1
57
3189
1
1
7
use File::Basename qw(fileparse);
1
2
1
427
3190
3191
sub lookup {
3192
0
0
my ($self, $name, $sid) = @_;
3193
3194
0
0
if(! exists $self->{'sources'}{$sid}) {
3195
0
return undef;
3196
}
3197
3198
0
my $src = $self->{'sources'}{$sid};
3199
0
0
if($src->{'type'} ne 'local') {
3200
0
say "unhandled src type ". $src->{'type'};
3201
0
return undef;
3202
}
3203
0
my $location = $src->{'folder'};
3204
0
my $absolute = abs_path($location.'/'.$name);
3205
0
0
return undef if( ! $absolute);
3206
0
0
return undef if ($absolute !~ /^$location/);
3207
0
return _media_filepath_to_src_file($absolute, $location);
3208
}
3209
3210
sub _media_filepath_to_src_file {
3211
0
0
my ($filepath, $flocation) = @_;
3212
0
my ($name, $loc, $ext) = fileparse($filepath, '\.[^\.]*');
3213
0
$ext =~ s/^\.//;
3214
0
return { 'filepath' => $filepath, 'name' => $name, 'containingdir' => $loc, 'ext' => $ext, 'fullname' => substr($filepath, length($flocation)+1), 'root' => $flocation};
3215
}
3216
3217
sub new {
3218
0
0
my ($class, $sources) = @_;
3219
0
my %self = ('sources' => $sources);
3220
0
bless \%self, $class;
3221
0
return \%self;
3222
}
3223
3224
1;
3225
}
3226
3227
package MHFS::BitTorrent::Client {
3228
1
1
16
use strict; use warnings;
1
1
2
1
29
1
6
1
2
1
25
3229
1
1
6
use feature 'say';
1
1
1
2583
3230
3231
sub rtxmlrpc {
3232
0
0
my ($server, $params, $cb, $inputdata) = @_;
3233
0
my $process;
3234
0
my @cmd = ('rtxmlrpc', @$params, '--config-dir', $server->{settings}{'CFGDIR'} . '/.pyroscope/');
3235
0
print "$_ " foreach @cmd;
3236
0
print "\n";
3237
$process = MHFS::Process->new_io_process($server->{evp}, \@cmd, sub {
3238
0
0
my ($output, $error) = @_;
3239
0
chomp $output;
3240
#say 'rtxmlrpc output: ' . $output;
3241
0
$cb->($output);
3242
0
}, $inputdata);
3243
3244
0
0
if(! $process) {
3245
0
$cb->(undef);
3246
}
3247
3248
0
return $process;
3249
}
3250
3251
sub torrent_d_bytes_done {
3252
0
0
my ($server, $infohash, $callback) = @_;
3253
rtxmlrpc($server, ['d.bytes_done', $infohash ], sub {
3254
0
0
my ($output) = @_;
3255
0
0
if($output =~ /ERROR/) {
3256
0
$output = undef;
3257
}
3258
0
$callback->($output);
3259
0
});
3260
}
3261
3262
sub torrent_d_size_bytes {
3263
0
0
my ($server, $infohash, $callback) = @_;
3264
rtxmlrpc($server, ['d.size_bytes', $infohash ],sub {
3265
0
0
my ($output) = @_;
3266
0
0
if($output =~ /ERROR/) {
3267
0
$output = undef;
3268
}
3269
0
$callback->($output);
3270
0
});
3271
}
3272
3273
sub torrent_load_verbose {
3274
0
0
my ($server, $filename, $callback) = @_;
3275
rtxmlrpc($server, ['load.verbose', '', $filename], sub {
3276
0
0
my ($output) = @_;
3277
0
0
if($output =~ /ERROR/) {
3278
0
$output = undef;
3279
}
3280
0
$callback->($output);
3281
0
});
3282
}
3283
3284
sub torrent_load_raw_verbose {
3285
0
0
my ($server, $data, $callback) = @_;
3286
rtxmlrpc($server, ['load.raw_verbose', '', '@-'], sub {
3287
0
0
my ($output) = @_;
3288
0
0
if($output =~ /ERROR/) {
3289
0
$output = undef;
3290
}
3291
0
$callback->($output);
3292
0
}, $data);
3293
}
3294
3295
sub torrent_d_directory_set {
3296
0
0
my ($server, $infohash, $directory, $callback) = @_;
3297
rtxmlrpc($server, ['d.directory.set', $infohash, $directory], sub {
3298
0
0
my ($output) = @_;
3299
0
0
if($output =~ /ERROR/) {
3300
0
$output = undef;
3301
}
3302
0
$callback->($output);
3303
0
});
3304
}
3305
3306
sub torrent_d_start {
3307
0
0
my ($server, $infohash, $callback) = @_;
3308
rtxmlrpc($server, ['d.start', $infohash], sub {
3309
0
0
my ($output) = @_;
3310
0
0
if($output =~ /ERROR/) {
3311
0
$output = undef;
3312
}
3313
0
$callback->($output);
3314
0
});
3315
}
3316
3317
sub torrent_d_delete_tied {
3318
0
0
my ($server, $infohash, $callback) = @_;
3319
rtxmlrpc($server, ['d.delete_tied', $infohash], sub {
3320
0
0
my ($output) = @_;
3321
0
0
if($output =~ /ERROR/) {
3322
0
$output = undef;
3323
}
3324
0
$callback->($output);
3325
0
});
3326
}
3327
3328
3329
sub torrent_d_name {
3330
0
0
my ($server, $infohash, $callback) = @_;
3331
rtxmlrpc($server, ['d.name', $infohash], sub {
3332
0
0
my ($output) = @_;
3333
0
0
if($output =~ /ERROR/) {
3334
0
$output = undef;
3335
}
3336
0
$callback->($output);
3337
0
});
3338
}
3339
3340
sub torrent_d_is_multi_file {
3341
0
0
my ($server, $infohash, $callback) = @_;
3342
rtxmlrpc($server, ['d.is_multi_file', $infohash], sub {
3343
0
0
my ($output) = @_;
3344
0
0
if($output =~ /ERROR/) {
3345
0
$output = undef;
3346
}
3347
0
$callback->($output);
3348
0
});
3349
}
3350
3351
3352
sub torrent_set_priority {
3353
0
0
my ($server, $infohash, $priority, $callback) = @_;
3354
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.priority.set=' . $priority], sub {
3355
0
0
my ($output) = @_;
3356
0
0
if($output =~ /ERROR/) {
3357
0
$callback->(undef);
3358
0
return;
3359
}
3360
rtxmlrpc($server, ['d.update_priorities', $infohash], sub {
3361
0
0
if($output =~ /ERROR/) {
3362
0
$output = undef;
3363
}
3364
0
$callback->($output);
3365
0
})});
0
3366
}
3367
3368
3369
# lookup the findex for the file and then set the priority on it
3370
# ENOTIMPLEMENTED
3371
sub torrent_set_file_priority {
3372
0
0
my ($server, $infohash, $file, $priority, $callback) = @_;
3373
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.path='], sub {
3374
0
0
my ($output) = @_;
3375
0
0
if($output =~ /ERROR/) {
3376
0
$callback->(undef);
3377
0
return;
3378
}
3379
0
say "torrent_set_file_priority";
3380
0
say $output;
3381
0
die;
3382
3383
0
$callback->($output);
3384
0
});
3385
}
3386
3387
sub torrent_list_torrents {
3388
0
0
my ($server, $callback) = @_;
3389
rtxmlrpc($server, ['d.multicall2', '', 'default', 'd.name=', 'd.hash=', 'd.size_bytes=', 'd.bytes_done=', 'd.is_private='], sub {
3390
0
0
my ($output) = @_;
3391
0
0
if($output =~ /ERROR/) {
3392
0
$output = undef;
3393
}
3394
0
$callback->($output);
3395
0
});
3396
}
3397
3398
sub torrent_file_information {
3399
0
0
my ($server, $infohash, $name, $cb) = @_;
3400
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.path=', 'f.size_bytes='], sub {
3401
0
0
my ($output) = @_;
3402
0
0
if($output =~ /ERROR/) {
3403
0
$output = undef;
3404
}
3405
3406
# pase the name and size arrays
3407
0
my %files;
3408
0
my @lines = split(/\n/, $output);
3409
0
while(1) {
3410
0
my $line = shift @lines;
3411
0
0
last if(!defined $line);
3412
0
0
if(substr($line, 0, 1) ne '[') {
3413
0
say "fail parse";
3414
0
$cb->(undef);
3415
0
return;
3416
}
3417
0
while(substr($line, -1) ne ']') {
3418
0
my $newline = shift @lines;
3419
0
0
if(!defined $newline) {
3420
0
say "fail parse";
3421
0
$cb->(undef);
3422
0
return;
3423
}
3424
0
$line .= $newline;
3425
}
3426
0
my ($file, $size) = $line =~ /^\[.(.+).,\s(\d+)\]$/;
3427
0
0
0
if((! defined $file) || (!defined $size)) {
3428
0
say "fail parse";
3429
0
$cb->(undef);
3430
0
return;
3431
}
3432
0
$files{$file} = {'size' => $size};
3433
}
3434
3435
0
my @fkeys = (keys %files);
3436
0
0
if(@fkeys == 1) {
3437
0
my $key = $fkeys[0];
3438
torrent_d_is_multi_file($server, $infohash, sub {
3439
0
my ($res) = @_;
3440
0
0
if(! defined $res) {
3441
0
$cb->(undef);
3442
}
3443
0
0
if($res == 1) {
3444
0
%files = ( $name . '/' . $key => $files{$key});
3445
}
3446
0
$cb->(\%files);
3447
0
});
3448
0
return;
3449
}
3450
0
my %newfiles;
3451
0
foreach my $key (@fkeys) {
3452
0
$newfiles{$name . '/' . $key} = $files{$key};
3453
}
3454
0
$cb->(\%newfiles);
3455
0
});
3456
}
3457
3458
sub torrent_start {
3459
0
0
my ($server, $torrentData, $saveto, $cb) = @_;
3460
0
my $torrent = MHFS::BitTorrent::Metainfo::Parse($torrentData);
3461
0
0
if(! $torrent) {
3462
0
$cb->{on_failure}->(); return;
0
3463
}
3464
0
my $asciihash = $torrent->InfohashAsHex();
3465
0
say 'infohash ' . $asciihash;
3466
3467
# see if the hash is already in rtorrent
3468
torrent_d_bytes_done($server, $asciihash, sub {
3469
0
0
my ($bytes_done) = @_;
3470
0
0
if(! defined $bytes_done) {
3471
# load, set directory, and download it (race condition)
3472
# 02/05/2020 what race condition?
3473
torrent_load_raw_verbose($server, $$torrentData, sub {
3474
0
0
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
0
0
3475
3476
torrent_d_directory_set($server, $asciihash, $saveto, sub {
3477
0
0
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
0
0
3478
3479
torrent_d_start($server, $asciihash, sub {
3480
0
0
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
0
0
3481
3482
0
say 'starting ' . $asciihash;
3483
0
$cb->{on_success}->($asciihash);
3484
0
})})});
0
0
3485
}
3486
else {
3487
# set the priority and download
3488
torrent_set_priority($server, $asciihash, '1', sub {
3489
0
0
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
0
0
3490
3491
torrent_d_start($server, $asciihash, sub {
3492
0
0
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
0
0
3493
3494
0
say 'starting (existing) ' . $asciihash;
3495
0
$cb->{on_success}->($asciihash);
3496
0
})});
0
3497
}
3498
0
});
3499
}
3500
3501
1;
3502
}
3503
3504
package MHFS::Plugin::MusicLibrary {
3505
1
1
70
use strict; use warnings;
1
1
3
1
26
1
6
1
2
1
27
3506
1
1
5
use feature 'say';
1
2
1
72
3507
1
1
6
use Cwd qw(abs_path getcwd);
1
1
1
55
3508
1
1
7
use File::Find;
1
1
1
52
3509
1
1
6
use Data::Dumper;
1
2
1
45
3510
1
1
7
use Devel::Peek;
1
2
1
9
3511
1
1
135
use Fcntl ':mode';
1
2
1
287
3512
1
1
8
use File::stat;
1
2
1
9
3513
1
1
69
use File::Basename;
1
2
1
53
3514
1
1
6
use File::Path qw(make_path);
1
2
1
62
3515
1
1
44
use Scalar::Util qw(looks_like_number);
1
3
1
116
3516
MHFS::Util->import();
3517
BEGIN {
3518
1
50
1
83
if( ! (eval "use JSON; 1")) {
1
1
154
0
0
0
0
3519
1
50
1
67
eval "use JSON::PP; 1" or die "No implementation of JSON available";
1
6
1
2
1
51
3520
1
83
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
3521
}
3522
}
3523
1
1
7
use Encode qw(decode encode);
1
2
1
46
3524
1
1
6
use URI::Escape;
1
1
1
62
3525
1
1
6
use Storable qw(dclone);
1
3
1
41
3526
1
1
5
use Fcntl ':mode';
1
2
1
335
3527
1
1
8
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
1
2
1
11
3528
1
1
135
use Scalar::Util qw(looks_like_number weaken);
1
2
1
57
3529
1
1
6
use POSIX qw/ceil/;
1
2
1
7
3530
1
1
81
use Storable qw( freeze thaw);
1
2
1
40
3531
#use ExtUtils::testlib;
3532
1
1
5
use FindBin;
1
2
1
42
3533
1
1
6
use File::Spec;
1
2
1
28
3534
1
1
5
use List::Util qw[min max];
1
1
1
66
3535
1
1
1179
use HTML::Template;
1
13595
1
70
3536
3537
# Optional dependency, MHFS::XS
3538
BEGIN {
3539
1
1
12
use constant HAS_MHFS_XS => (eval "use MHFS::XS; 1");
1
1
2
1
70
1
329
0
0
0
0
3540
1
50
1
10
if(! HAS_MHFS_XS) {
3541
1
6277
warn __PACKAGE__.": XS not available";
3542
}
3543
}
3544
3545
# read the directory tree from desk and store
3546
# 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
3547
sub BuildLibrary {
3548
0
0
my ($path) = @_;
3549
0
my $statinfo = stat($path);
3550
0
0
return undef if(! $statinfo);
3551
0
my $basepath = basename($path);
3552
0
my $utf8name = get_printable_utf8($basepath);
3553
3554
0
0
if(!S_ISDIR($statinfo->mode)){
3555
0
0
return undef if($path !~ /\.(flac|mp3|m4a|wav|ogg|webm)$/);
3556
0
return [$basepath, $statinfo->size, undef, $utf8name];
3557
}
3558
else {
3559
0
my $dir;
3560
0
0
if(! opendir($dir, $path)) {
3561
0
warn "outputdir: Cannot open directory: $path $!";
3562
0
return undef;
3563
}
3564
0
my @files = sort { uc($a) cmp uc($b)} (readdir $dir);
0
3565
0
closedir($dir);
3566
0
my @tree;
3567
0
my $size = 0;
3568
0
foreach my $file (@files) {
3569
0
0
0
next if(($file eq '.') || ($file eq '..'));
3570
0
0
if(my $file = BuildLibrary("$path/$file")) {
3571
0
push @tree, $file;
3572
0
$size += $file->[1];
3573
}
3574
}
3575
0
0
return undef if( $size eq 0);
3576
0
return [$basepath, $size, \@tree, $utf8name];
3577
}
3578
}
3579
3580
sub ToHTML {
3581
0
0
my ($files, $where) = @_;
3582
0
0
$where //= '';
3583
0
my $buf = '';
3584
#my $name_unencoded = decode('UTF-8', $files->[0]);
3585
0
my $name_unencoded = $files->[3];
3586
0
my $name = ${escape_html_noquote($name_unencoded)};
0
3587
0
0
if($files->[2]) {
3588
0
my $dir = $files->[0];
3589
0
$buf .= ' ';
3590
0
$buf .= ' ';
3591
0
$buf .= '';
3602
0
$buf .= ' ';
3603
3604
}
3605
else {
3606
0
0
if($where eq '') {
3607
0
$buf .= '';
3616
0
return $buf;
3617
}
3618
}
3619
0
$buf .= ' ';
3620
0
return $buf;
3621
}
3622
3623
sub toJSON {
3624
0
0
my ($self) = @_;
3625
0
my $head = {'files' => []};
3626
0
my @nodestack = ($head);
3627
0
my @files = (@{$self->{'library'}});
0
3628
0
while(@files) {
3629
0
my $file = shift @files;
3630
0
0
if( ! $file) {
3631
0
pop @nodestack;
3632
0
next;
3633
}
3634
0
my $node = $nodestack[@nodestack - 1];
3635
#my $newnode = {'name' => decode('UTF-8', $file->[0])};
3636
0
my $newnode = {'name' =>$file->[3]};
3637
0
0
if($file->[2]) {
3638
0
$newnode->{'files'} = [];
3639
0
push @nodestack, $newnode;
3640
0
@files = (@{$file->[2]}, undef, @files);
0
3641
}
3642
0
push @{$node->{'files'}}, $newnode;
0
3643
}
3644
# encode json outputs bytes NOT unicode string
3645
0
return encode_json($head);
3646
}
3647
3648
3649
sub LibraryHTML {
3650
0
0
my ($self) = @_;
3651
0
my $buf = '';
3652
0
foreach my $file (@{$self->{'library'}}) {
0
3653
0
$buf .= ToHTML($file);
3654
0
$buf .= '
3655
}
3656
3657
0
my $legacy_template = HTML::Template->new(filename => 'templates/music_legacy.html', path => $self->{'settings'}{'APPDIR'} );
3658
0
$legacy_template->param(musicdb => $buf);
3659
0
$self->{'html'} = encode('UTF-8', $legacy_template->output, Encode::FB_CROAK);
3660
3661
0
$self->{'musicdbhtml'} = encode('UTF-8', $buf, Encode::FB_CROAK);
3662
0
$self->{'musicdbjson'} = toJSON($self);
3663
}
3664
3665
sub SendLibrary {
3666
0
0
my ($self, $request) = @_;
3667
3668
# maybe not allow everyone to do these commands?
3669
0
0
if($request->{'qs'}{'forcerefresh'}) {
0
3670
0
say __PACKAGE__.": forcerefresh";
3671
0
$self->BuildLibraries();
3672
}
3673
elsif($request->{'qs'}{'refresh'}) {
3674
0
say __PACKAGE__.": refresh";
3675
UpdateLibrariesAsync($self, $request->{'client'}{'server'}{'evp'}, sub {
3676
0
0
say __PACKAGE__.": refresh done";
3677
0
$request->{'qs'}{'refresh'} = 0;
3678
0
SendLibrary($self, $request);
3679
0
});
3680
0
return 1;
3681
}
3682
3683
# deduce the format if not provided
3684
0
my $fmt = $request->{'qs'}{'fmt'};
3685
0
0
if(! $fmt) {
3686
0
$fmt = 'worklet';
3687
0
my $fallback = 'musicinc';
3688
0
0
if($request->{'header'}{'User-Agent'} =~ /Chrome\/([^\.]+)/) {
0
3689
0
my $ver = $1;
3690
# SharedArrayBuffer support with spectre/meltdown fixes was added in 68
3691
# AudioWorklet on linux had awful glitching until somewhere in 92 https://bugs.chromium.org/p/chromium/issues/detail?id=825823
3692
0
0
if($ver < 93) {
3693
0
0
0
if(($ver < 68) || ($request->{'header'}{'User-Agent'} =~ /Linux/)) {
3694
0
$fmt = $fallback;
3695
}
3696
}
3697
}
3698
elsif($request->{'header'}{'User-Agent'} =~ /Firefox\/([^\.]+)/) {
3699
0
my $ver = $1;
3700
# SharedArrayBuffer support with spectre/meltdown fixes was added in 79
3701
0
0
if($ver < 79) {
3702
0
$fmt = $fallback;
3703
}
3704
}
3705
else {
3706
# Hope for the best, assume worklet works
3707
}
3708
3709
# leave this here for now to not break the segment based players
3710
0
0
if($request->{'qs'}{'segments'}) {
3711
0
$fmt = $fallback;
3712
}
3713
}
3714
3715
# route
3716
0
0
my $qs = defined($request->{'qs'}{'ptrack'}) ? {'ptrack' => $request->{'qs'}{'ptrack'}} : undef;
3717
0
0
if($fmt eq 'worklet') {
0
0
0
0
0
3718
0
return $request->SendRedirect(307, 'static/music_worklet_inprogress/', $qs);
3719
}
3720
elsif($fmt eq 'musicdbjson') {
3721
0
return $request->SendBytes('application/json', $self->{'musicdbjson'});
3722
}
3723
elsif($fmt eq 'musicdbhtml') {
3724
0
return $request->SendBytes("text/html; charset=utf-8", $self->{'musicdbhtml'});
3725
}
3726
elsif($fmt eq 'gapless') {
3727
0
$qs->{fmt} = 'musicinc';
3728
0
return $request->SendRedirect(301, "music", $qs);
3729
}
3730
elsif($fmt eq 'musicinc') {
3731
0
return $request->SendRedirect(307, 'static/music_inc/', $qs);
3732
}
3733
elsif($fmt eq 'legacy') {
3734
0
say __PACKAGE__.": legacy";
3735
0
return $request->SendBytes("text/html; charset=utf-8", $self->{'html'});
3736
}
3737
else {
3738
0
return $request->Send404;
3739
}
3740
}
3741
3742
my $SEGMENT_DURATION = 5;
3743
my %TRACKDURATION;
3744
my %TRACKINFO;
3745
sub SendTrack {
3746
0
0
my ($request, $tosend) = @_;
3747
0
0
0
if(defined $request->{'qs'}{'part'}) {
0
3748
0
0
if(! HAS_MHFS_XS) {
3749
0
say __PACKAGE__.": route not available without XS";
3750
0
$request->Send503();
3751
0
return;
3752
}
3753
3754
0
0
if(! $TRACKDURATION{$tosend}) {
3755
0
say __PACKAGE__.": failed to get track duration";
3756
0
$request->Send503();
3757
0
return;
3758
}
3759
3760
0
say "no proc, duration cached";
3761
0
my $pv = MHFS::XS::new($tosend);
3762
0
$request->{'outheaders'}{'X-MHFS-NUMSEGMENTS'} = ceil($TRACKDURATION{$tosend} / $SEGMENT_DURATION);
3763
0
$request->{'outheaders'}{'X-MHFS-TRACKDURATION'} = $TRACKDURATION{$tosend};
3764
0
$request->{'outheaders'}{'X-MHFS-MAXSEGDURATION'} = $SEGMENT_DURATION;
3765
0
my $samples_per_seg = $TRACKINFO{$tosend}{'SAMPLERATE'} * $SEGMENT_DURATION;
3766
0
my $spos = $samples_per_seg * ($request->{'qs'}{'part'} - 1);
3767
0
my $samples_left = $TRACKINFO{$tosend}{'TOTALSAMPLES'} - $spos;
3768
0
0
my $res = MHFS::XS::get_flac($pv, $spos, $samples_per_seg < $samples_left ? $samples_per_seg : $samples_left);
3769
0
$request->SendBytes('audio/flac', $res);
3770
}
3771
elsif(defined $request->{'qs'}{'fmt'} && ($request->{'qs'}{'fmt'} eq 'wav')) {
3772
0
0
if(! HAS_MHFS_XS) {
3773
0
say __PACKAGE__.": route not available without XS";
3774
0
$request->Send503();
3775
0
return;
3776
}
3777
3778
0
my $pv = MHFS::XS::new($tosend);
3779
0
my $outbuf = '';
3780
0
my $wavsize = (44+ $TRACKINFO{$tosend}{'TOTALSAMPLES'} * ($TRACKINFO{$tosend}{'BITSPERSAMPLE'}/8) * $TRACKINFO{$tosend}{'NUMCHANNELS'});
3781
0
0
my $startbyte = $request->{'header'}{'_RangeStart'} || 0;
3782
0
0
my $endbyte = $request->{'header'}{'_RangeEnd'} // $wavsize-1;
3783
0
say "start byte" . $startbyte;
3784
0
say "end byte " . $endbyte;
3785
0
say "MHFS::XS::wavvfs_read_range " . $startbyte . ' ' . $endbyte;
3786
0
my $maxsendsize;
3787
0
$maxsendsize = 1048576/2;
3788
0
say "maxsendsize $maxsendsize " . ' bytespersample ' . ($TRACKINFO{$tosend}{'BITSPERSAMPLE'}/8) . ' numchannels ' . $TRACKINFO{$tosend}{'NUMCHANNELS'};
3789
$request->SendCallback(sub{
3790
0
0
my ($fileitem) = @_;
3791
0
my $actual_endbyte = $startbyte + $maxsendsize - 1;
3792
0
0
if($actual_endbyte >= $endbyte) {
3793
0
$actual_endbyte = $endbyte;
3794
0
$fileitem->{'cb'} = undef;
3795
0
say "SendCallback last send";
3796
}
3797
0
my $actual_startbyte = $startbyte;
3798
0
$startbyte = $actual_endbyte+1;
3799
0
say "SendCallback wavvfs_read_range " . $actual_startbyte . ' ' . $actual_endbyte;
3800
0
return MHFS::XS::wavvfs_read_range($pv, $actual_startbyte, $actual_endbyte);
3801
}, {
3802
0
'mime' => 'audio/wav',
3803
'size' => $wavsize,
3804
});
3805
3806
}
3807
else {
3808
0
0
0
if($request->{'qs'}{'action'} && ($request->{'qs'}{'action'} eq 'dl')) {
0
3809
0
$request->{'responseopt'}{'cd_file'} = 'attachment';
3810
}
3811
# Send the total pcm frame count for mp3
3812
elsif(lc(substr($tosend, -4)) eq '.mp3') {
3813
0
0
if(HAS_MHFS_XS) {
3814
0
0
if(! $TRACKINFO{$tosend}) {
3815
0
$TRACKINFO{$tosend} = { 'TOTALSAMPLES' => MHFS::XS::get_totalPCMFrameCount($tosend) };
3816
0
say "mp3 totalPCMFrames: " . $TRACKINFO{$tosend}{'TOTALSAMPLES'};
3817
}
3818
0
$request->{'outheaders'}{'X-MHFS-totalPCMFrameCount'} = $TRACKINFO{$tosend}{'TOTALSAMPLES'};
3819
}
3820
}
3821
0
$request->SendLocalFile($tosend);
3822
}
3823
}
3824
3825
sub parseStreamInfo {
3826
# https://metacpan.org/source/DANIEL/Audio-FLAC-Header-2.4/Header.pm
3827
0
0
my ($buf) = @_;
3828
0
my $metaBinString = unpack('B144', $buf);
3829
3830
0
my $x32 = 0 x 32;
3831
0
my $info = {};
3832
0
$info->{'MINIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 0, 16), -32)));
3833
0
$info->{'MAXIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 16, 16), -32)));
3834
0
$info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 32, 24), -32)));
3835
0
$info->{'MAXIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 56, 24), -32)));
3836
3837
0
$info->{'SAMPLERATE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 80, 20), -32)));
3838
0
$info->{'NUMCHANNELS'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 3), -32))) + 1;
3839
0
$info->{'BITSPERSAMPLE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 103, 5), -32))) + 1;
3840
3841
# Calculate total samples in two parts
3842
0
my $highBits = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 108, 4), -32)));
3843
3844
0
$info->{'TOTALSAMPLES'} = $highBits * 2 ** 32 +
3845
unpack('N', pack('B32', substr($x32 . substr($metaBinString, 112, 32), -32)));
3846
3847
# Return the MD5 as a 32-character hexadecimal string
3848
0
$info->{'MD5CHECKSUM'} = unpack('H32',substr($buf, 18, 16));
3849
0
return $info;
3850
}
3851
3852
sub GetTrackInfo {
3853
0
0
my ($file) = @_;
3854
0
0
open(my $fh, '<', $file) or die "open failed";
3855
0
my $buf = '';
3856
0
0
seek($fh, 8, 0) or die "seek failed";
3857
0
0
(read($fh, $buf, 34) == 34) or die "short read";
3858
0
my $info = parseStreamInfo($buf);
3859
0
$info->{'duration'} = $info->{'TOTALSAMPLES'}/$info->{'SAMPLERATE'};
3860
0
print Dumper($info);
3861
0
return $info;
3862
}
3863
3864
sub SendLocalTrack {
3865
0
0
my ($request, $file) = @_;
3866
3867
# fast path, just send the file
3868
0
0
my $justsendfile = (!defined($request->{'qs'}{'fmt'})) && (!defined($request->{'qs'}{'max_sample_rate'})) && (!defined($request->{'qs'}{'bitdepth'})) && (!defined($request->{'qs'}{'part'}));
3869
0
0
if($justsendfile) {
3870
0
SendTrack($request, $file);
3871
0
return;
3872
}
3873
3874
0
my $evp = $request->{'client'}{'server'}{'evp'};
3875
0
my $tmpfileloc = $request->{'client'}{'server'}{'settings'}{'MUSIC_TMPDIR'} . '/';
3876
0
my $nameloc = $request->{'localtrack'}{'nameloc'};
3877
0
0
$tmpfileloc .= $nameloc if($nameloc);
3878
0
my $filebase = $request->{'localtrack'}{'basename'};
3879
3880
# convert to lossy flac if necessary
3881
0
my $is_flac = lc(substr($file, -5)) eq '.flac';
3882
0
0
if(!$is_flac) {
3883
0
$filebase =~ s/\.[^.]+$/.lossy.flac/;
3884
0
$request->{'localtrack'}{'basename'} = $filebase;
3885
0
my $tlossy = $tmpfileloc . $filebase;
3886
0
0
if(-e $tlossy ) {
3887
0
$is_flac = 1;
3888
0
$file = $tlossy;
3889
3890
0
0
if(defined LOCK_GET_LOCKDATA($tlossy)) {
3891
# unlikely
3892
0
say "SendLocalTrack: lossy flac exists and is locked 503";
3893
0
$request->Send503;
3894
0
return;
3895
}
3896
}
3897
else {
3898
0
make_path($tmpfileloc, {chmod => 0755});
3899
0
my @cmd = ('ffmpeg', '-i', $file, '-c:a', 'flac', '-sample_fmt', 's16', $tlossy);
3900
0
my $buf;
3901
0
0
if(LOCK_WRITE($tlossy)) {
3902
$request->{'process'} = MHFS::Process->new(\@cmd, $evp, {
3903
'SIGCHLD' => sub {
3904
0
0
UNLOCK_WRITE($tlossy);
3905
0
SendLocalTrack($request,$tlossy);
3906
},
3907
'STDERR' => sub {
3908
0
0
my ($terr) = @_;
3909
0
read($terr, $buf, 4096);
3910
0
}});
3911
}
3912
else {
3913
# unlikely
3914
0
say "SendLocalTrack: lossy flac is locked 503";
3915
0
$request->Send503;
3916
}
3917
3918
0
return;
3919
}
3920
}
3921
3922
# everything should be flac now, grab the track info
3923
0
0
if(!defined($TRACKINFO{$file}))
3924
{
3925
0
$TRACKINFO{$file} = GetTrackInfo($file);
3926
0
$TRACKDURATION{$file} = $TRACKINFO{$file}{'duration'};
3927
}
3928
3929
0
0
my $max_sample_rate = $request->{'qs'}{'max_sample_rate'} // 192000;
3930
0
0
0
my $bitdepth = $request->{'qs'}{'bitdepth'} // ($max_sample_rate > 48000 ? 24 : 16);
3931
3932
# check to see if the raw file fullfills the requirements
3933
0
my $samplerate = $TRACKINFO{$file}{'SAMPLERATE'};
3934
0
my $inbitdepth = $TRACKINFO{$file}{'BITSPERSAMPLE'};
3935
0
say "input: samplerate $samplerate inbitdepth $inbitdepth";
3936
0
say "maxsamplerate $max_sample_rate bitdepth $bitdepth";
3937
0
0
0
if(($samplerate <= $max_sample_rate) && ($inbitdepth <= $bitdepth)) {
3938
0
say "samplerate is <= max_sample_rate, not resampling";
3939
0
SendTrack($request, $file);
3940
0
return;
3941
}
3942
3943
# determine the acceptable samplerate, bitdepth combinations to send
3944
0
my %rates = (
3945
'48000' => [192000, 96000, 48000],
3946
'44100' => [176400, 88200, 44100]
3947
);
3948
0
my @acceptable_settings = ( [24, 192000], [24, 96000], [24, 48000], [24, 176400], [24, 88200], [16, 48000], [16, 44100]);
3949
0
my @desired = ([$bitdepth, $max_sample_rate]);
3950
0
foreach my $setting (@acceptable_settings) {
3951
0
0
0
if(($setting->[0] <= $bitdepth) && ($setting->[1] <= $max_sample_rate)) {
3952
0
push @desired, $setting;
3953
}
3954
}
3955
3956
# if we already transcoded/resampled, don't waste time doing it again
3957
0
foreach my $setting (@desired) {
3958
0
my $tmpfile = $tmpfileloc . $setting->[0] . '_' . $setting->[1] . '_' . $filebase;
3959
0
0
if(-e $tmpfile) {
3960
0
say "No need to resample $tmpfile exists";
3961
0
SendTrack($request, $tmpfile);
3962
0
return;
3963
}
3964
}
3965
0
make_path($tmpfileloc, {chmod => 0755});
3966
3967
# resampling
3968
0
my $desiredrate;
3969
0
RATE_FACTOR: foreach my $key (keys %rates) {
3970
0
0
if(($samplerate % $key) == 0) {
3971
0
foreach my $rate (@{$rates{$key}}) {
0
3972
0
0
0
if(($rate <= $samplerate) && ($rate <= $max_sample_rate)) {
3973
0
$desiredrate = $rate;
3974
0
last RATE_FACTOR;
3975
}
3976
}
3977
}
3978
}
3979
0
0
$desiredrate //= $max_sample_rate;
3980
0
say "desired rate: $desiredrate";
3981
# build the command
3982
0
my $outfile = $tmpfileloc . $bitdepth . '_' . $desiredrate . '_' . $filebase;
3983
0
my @cmd = ('sox', $file, '-G', '-b', $bitdepth, $outfile, 'rate', '-v', '-L', $desiredrate, 'dither');
3984
0
say "cmd: " . join(' ', @cmd);
3985
3986
0
0
if(LOCK_WRITE($outfile)) {
3987
$request->{'process'} = MHFS::Process->new(\@cmd, $evp, {
3988
'SIGCHLD' => sub {
3989
0
0
UNLOCK_WRITE($outfile);
3990
# BUG? files isn't necessarily flushed to disk on SIGCHLD. filesize can be wrong
3991
0
SendTrack($request, $outfile);
3992
},
3993
'STDERR' => sub {
3994
0
0
my ($terr) = @_;
3995
0
my $buf;
3996
0
read($terr, $buf, 4096);
3997
0
}});
3998
}
3999
else {
4000
# unlikely
4001
0
say "SendLocalTrack: sox is locked 503";
4002
0
$request->Send503;
4003
}
4004
0
return;
4005
}
4006
4007
4008
sub BuildLibraries {
4009
0
0
my ($self) = @_;
4010
0
my @wholeLibrary;
4011
4012
0
$self->{'sources'} = [];
4013
4014
0
foreach my $sid (@{$self->{'settings'}{'MEDIASOURCES'}{'music'}}) {
0
4015
0
my $source = $self->{'settings'}{'SOURCES'}{$sid};
4016
0
my $lib;
4017
0
0
if($source->{'type'} eq 'local') {
0
0
4018
0
say __PACKAGE__.": building music " . clock_gettime(CLOCK_MONOTONIC);
4019
0
$lib = BuildLibrary($source->{'folder'});
4020
0
say __PACKAGE__.": done building music " . clock_gettime(CLOCK_MONOTONIC);
4021
}
4022
elsif($source->{'type'} eq 'ssh') {
4023
}
4024
elsif($source->{'type'} eq 'mhfs') {
4025
}
4026
4027
0
0
if(!$lib) {
4028
0
warn "invalid source: " . $source->{'type'};
4029
0
0
warn 'folder: '. $source->{'folder'} if($source->{'type'} eq 'local');
4030
0
next;
4031
}
4032
0
push @{$self->{'sources'}}, [$sid, $lib];
0
4033
0
OUTER: foreach my $item (@{$lib->[2]}) {
0
4034
0
foreach my $already (@wholeLibrary) {
4035
0
0
next OUTER if($already->[0] eq $item->[0]);
4036
}
4037
0
push @wholeLibrary, $item;
4038
}
4039
}
4040
0
$self->{'library'} = \@wholeLibrary;
4041
0
$self->LibraryHTML;
4042
0
return \@wholeLibrary;
4043
}
4044
4045
sub FindInLibrary {
4046
0
0
my ($self, $msource, $name) = @_;
4047
0
my @namearr = split('/', $name);
4048
0
my $finalstring = $self->{'settings'}{'SOURCES'}{$msource->[0]}{'folder'};
4049
0
my $lib = $msource->[1];
4050
0
FindInLibrary_Outer: foreach my $component (@namearr) {
4051
0
foreach my $libcomponent (@{$lib->[2]}) {
0
4052
0
0
if($libcomponent->[3] eq $component) {
4053
0
$finalstring .= "/".$libcomponent->[0];
4054
0
$lib = $libcomponent;
4055
0
next FindInLibrary_Outer;
4056
}
4057
}
4058
0
return undef;
4059
}
4060
return {
4061
0
'node' => $lib,
4062
'path' => $finalstring
4063
};
4064
}
4065
4066
# Define source types here
4067
my %sendFiles = (
4068
'local' => sub {
4069
my ($request, $file, $node, $source, $nameloc) = @_;
4070
return undef if(! -e $file);
4071
if( ! -d $file) {
4072
$request->{'localtrack'} = { 'nameloc' => $nameloc, 'basename' => $node->[0]};
4073
SendLocalTrack($request, $file);
4074
}
4075
else {
4076
$request->SendAsTar($file);
4077
}
4078
return 1;
4079
},
4080
'mhfs' => sub {
4081
my ($request, $file, $node, $source) = @_;
4082
return $request->Proxy($source, $node);
4083
},
4084
'ssh' => sub {
4085
my ($request, $file, $node, $source) = @_;
4086
return $request->SendFromSSH($source, $file, $node);
4087
},
4088
);
4089
4090
sub SendFromLibrary {
4091
0
0
my ($self, $request) = @_;
4092
0
my $utf8name = decode('UTF-8', $request->{'qs'}{'name'});
4093
0
foreach my $msource (@{$self->{'sources'}}) {
0
4094
0
my $node = $self->FindInLibrary($msource, $utf8name);
4095
0
0
next if ! $node;
4096
4097
0
my $nameloc;
4098
0
0
if($utf8name =~ /(.+\/).+$/) {
4099
0
$nameloc = $1;
4100
}
4101
0
my $source = $self->{'settings'}{'SOURCES'}{$msource->[0]};
4102
0
0
if($sendFiles{$source->{'type'}}->($request, $node->{'path'}, $node->{'node'}, $source, $nameloc)) {
4103
0
return 1;
4104
}
4105
}
4106
0
say "SendFromLibrary: did not find in library, 404ing";
4107
0
say "name: " . $request->{'qs'}{'name'};
4108
0
$request->Send404;
4109
}
4110
4111
sub SendResources {
4112
0
0
my ($self, $request) = @_;
4113
4114
0
0
if(! HAS_MHFS_XS) {
4115
0
say __PACKAGE__.": route not available without XS";
4116
0
$request->Send503();
4117
0
return;
4118
}
4119
4120
0
my $utf8name = decode('UTF-8', $request->{'qs'}{'name'});
4121
0
foreach my $msource (@{$self->{'sources'}}) {
0
4122
0
my $node = $self->FindInLibrary($msource, $utf8name);
4123
0
0
next if ! $node;
4124
0
my $comments = MHFS::XS::get_vorbis_comments($node->{'path'});
4125
0
my $commenthash = {};
4126
0
foreach my $comment (@{$comments}) {
0
4127
0
$comment = decode('UTF-8', $comment);
4128
0
my ($key, $value) = split('=', $comment);
4129
0
$commenthash->{$key} = $value;
4130
}
4131
0
$request->SendAsJSON($commenthash);
4132
0
return 1;
4133
}
4134
0
say "SendFromLibrary: did not find in library, 404ing";
4135
0
say "name: " . $request->{'qs'}{'name'};
4136
0
$request->Send404;
4137
}
4138
4139
sub SendArt {
4140
0
0
my ($self, $request) = @_;
4141
4142
0
my $utf8name = decode('UTF-8', $request->{'qs'}{'name'});
4143
0
foreach my $msource (@{$self->{'sources'}}) {
0
4144
0
my $node = $self->FindInLibrary($msource, $utf8name);
4145
0
0
next if ! $node;
4146
4147
0
my $dname = $node->{'path'};
4148
0
my $dh;
4149
0
0
if(! opendir($dh, $dname)) {
4150
0
$dname = dirname($node->{'path'});
4151
0
0
if(! opendir($dh, $dname)) {
4152
0
$request->Send404;
4153
0
return 1;
4154
}
4155
}
4156
4157
# scan dir for art
4158
0
my @files;
4159
0
while(my $fname = readdir($dh)) {
4160
0
my $last = lc(substr($fname, -4));
4161
0
0
0
push @files, $fname if(($last eq '.png') || ($last eq '.jpg') || ($last eq 'jpeg'));
0
4162
}
4163
0
closedir($dh);
4164
0
0
if( ! @files) {
4165
0
$request->Send404;
4166
0
return 1;
4167
}
4168
0
my $tosend = "$dname/" . $files[0];
4169
0
foreach my $file (@files) {
4170
0
foreach my $expname ('cover', 'front', 'album') {
4171
0
0
if(substr($file, 0, length($expname)) eq $expname) {
4172
0
$tosend = "$dname/$file";
4173
0
last;
4174
}
4175
}
4176
}
4177
0
say "tosend $tosend";
4178
0
$request->SendLocalFile($tosend);
4179
0
return 1;
4180
}
4181
}
4182
4183
sub UpdateLibrariesAsync {
4184
0
0
my ($self, $evp, $onUpdateEnd) = @_;
4185
MHFS::Process->new_output_child($evp, sub {
4186
# done in child
4187
0
0
my ($datachannel) = @_;
4188
4189
# save references to before
4190
0
my @potentialupdates = ('html', 'musicdbhtml', 'musicdbjson');
4191
0
my %before;
4192
0
foreach my $pupdate (@potentialupdates) {
4193
0
$before{$pupdate} = $self->{$pupdate};
4194
}
4195
4196
# build the new libraries
4197
0
$self->BuildLibraries();
4198
4199
# determine what needs to be updated
4200
0
my @updates = (['sources', $self->{'sources'}]);
4201
0
foreach my $pupdate(@potentialupdates) {
4202
0
0
if($before{$pupdate} ne $self->{$pupdate}) {
4203
0
push @updates, [$pupdate, $self->{$pupdate}];
4204
}
4205
}
4206
4207
# serialize and output
4208
0
my $pipedata = freeze(\@updates);
4209
0
print $datachannel $pipedata;
4210
0
exit 0;
4211
}, sub {
4212
0
0
my ($out, $err) = @_;
4213
0
say "BEGIN_FROM_CHILD---------";
4214
0
print $err;
4215
0
say "END_FROM_CHILD-----------";
4216
0
my $unthawed;
4217
{
4218
0
local $@;
0
4219
0
0
unless (eval {
4220
0
$unthawed = thaw($out);
4221
0
return 1;
4222
}) {
4223
0
warn("thaw threw exception");
4224
}
4225
}
4226
0
0
if($unthawed){
4227
0
foreach my $update (@$unthawed) {
4228
0
say "Updating " . $update->[0];
4229
0
$self->{$update->[0]} = $update->[1];
4230
}
4231
}
4232
else {
4233
0
say "failed to thaw, library not updated.";
4234
}
4235
0
$onUpdateEnd->();
4236
0
});
4237
}
4238
4239
sub new {
4240
0
0
my ($class, $settings) = @_;
4241
0
my $self = {'settings' => $settings};
4242
0
bless $self, $class;
4243
0
my $pstart = __PACKAGE__.":";
4244
4245
# no sources until loaded
4246
0
$self->{'sources'} = [];
4247
0
$self->{'html'} = __PACKAGE__.' not loaded';
4248
0
$self->{'musicdbhtml'} = __PACKAGE__.' not loaded';
4249
0
$self->{'musicdbjson'} = '{}';
4250
4251
my $musicpageroute = sub {
4252
0
0
my ($request) = @_;
4253
0
return $self->SendLibrary($request);
4254
0
};
4255
4256
my $musicdlroute = sub {
4257
0
0
my ($request) = @_;
4258
0
return $self->SendFromLibrary($request);
4259
0
};
4260
4261
my $musicresourcesroute = sub {
4262
0
0
my ($request) = @_;
4263
0
return $self->SendResources($request);
4264
0
};
4265
4266
$self->{'routes'} = [
4267
['/music', $musicpageroute],
4268
['/music_dl', $musicdlroute],
4269
['/music_resources', $musicresourcesroute],
4270
['/music_art', sub {
4271
0
0
my ($request) = @_;
4272
0
return $self->SendArt($request);
4273
0
}]
4274
];
4275
4276
$self->{'timers'} = [
4277
# update the library at start and periodically
4278
[0, 300, sub {
4279
0
0
my ($timer, $current_time, $evp) = @_;
4280
0
say "$pstart library timer";
4281
UpdateLibrariesAsync($self, $evp, sub {
4282
0
say "$pstart library timer done";
4283
0
});
4284
0
return 1;
4285
0
}],
4286
];
4287
4288
0
return $self;
4289
}
4290
4291
1;
4292
}
4293
4294
package MHFS::Plugin::Youtube {
4295
1
1
13
use strict; use warnings;
1
1
2
1
37
1
6
1
2
1
37
4296
1
1
14
use feature 'say';
1
2
1
95
4297
1
1
6
use Data::Dumper;
1
2
1
87
4298
1
1
7
use feature 'state';
1
2
1
29
4299
1
1
6
use Encode;
1
1
1
92
4300
1
1
7
use URI::Escape;
1
2
1
91
4301
1
1
8
use Scalar::Util qw(looks_like_number weaken);
1
2
1
65
4302
1
1
8
use File::stat;
1
2
1
11
4303
MHFS::Util->import();
4304
BEGIN {
4305
1
50
1
206
if( ! (eval "use JSON; 1")) {
1
1
185
0
0
0
0
4306
1
50
1
75
eval "use JSON::PP; 1" or die "No implementation of JSON available";
1
7
1
2
1
50
4307
1
2266
warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
4308
}
4309
}
4310
4311
sub searchbox {
4312
0
0
my ($self, $request) = @_;
4313
#my $html = '
4314
0
my $html = '
4315
0
$html .= '
4316
0
my $query = $request->{'qs'}{'q'};
4317
0
0
if($query) {
4318
0
$query =~ s/\+/ /g;
4319
0
my $escaped = escape_html($query);
4320
0
$html .= 'value="' . $$escaped . '"';
4321
}
4322
0
$html .= '>';
4323
0
0
if($request->{'qs'}{'media'}) {
4324
0
$html .= '
4325
}
4326
0
$html .= '
4327
0
$html .= '';
4328
0
return $html;
4329
}
4330
4331
sub ytplayer {
4332
0
0
my ($self, $request) = @_;
4333
0
my $html = '
4334
0
my $url = 'get_video?fmt=yt&id=' . uri_escape($request->{'qs'}{'id'});
4335
0
0
$url .= '&media=' . uri_escape($request->{'qs'}{'media'}) if($request->{'qs'}{'media'});
4336
0
0
0
if($request->{'qs'}{'media'} && ($request->{'qs'}{'media'} eq 'music')) {
4337
0
$request->{'path'}{'basename'} = 'ytaudio';
4338
0
$html .= 'Great Browser ';
4339
}
4340
else {
4341
0
$request->{'path'}{'basename'} = 'yt';
4342
0
$html .= 'Great Browser ';
4343
}
4344
0
return $html;
4345
}
4346
4347
sub sendAsHTML {
4348
0
0
my ($self, $request, $response) = @_;
4349
0
my $json = decode_json($response);
4350
0
0
if(! $json){
4351
0
$request->Send404;
4352
0
return;
4353
}
4354
0
my $html = $self->searchbox($request);
4355
0
$html .= '';
4356
0
foreach my $item (@{$json->{'items'}}) {
0
4357
0
my $id = $item->{'id'}{'videoId'};
4358
0
0
next if (! defined $id);
4359
0
$html .= '';
4360
0
my $mediaurl = 'ytplayer?fmt=yt&id=' . $id;
4361
0
my $media = $request->{'qs'}{'media'};
4362
0
0
$mediaurl .= '&media=' . uri_escape($media) if(defined $media);
4363
0
$html .= '' . $item->{'snippet'}{'title'} . ' ';
4364
0
$html .= '
4365
0
$html .= '
4366
0
$html .= ' ' . $item->{'snippet'}{'channelTitle'} . ' ';
4367
0
$html .= '' . $item->{'snippet'}{'description'} . '
';
4368
0
$html .= '
4369
0
$html .= ''
4370
}
4371
0
$html .= '';
4372
0
$html .= '';
4396
0
$request->SendHTML($html);
4397
}
4398
4399
sub onYoutube {
4400
0
0
my ($self, $request) = @_;
4401
0
my $evp = $request->{'client'}{'server'}{'evp'};
4402
0
0
my $youtubequery = 'q=' . (uri_escape($request->{'qs'}{'q'}) // '') . '&maxResults=' . ($request->{'qs'}{'maxResults'} // '25') . '&part=snippet&key=' . $self->{'settings'}{'Youtube'}{'key'};
0
4403
0
$youtubequery .= '&type=video'; # playlists not supported yet
4404
0
my $tosend = '';
4405
0
my @curlcmd = ('curl', '-G', '-d', $youtubequery, 'https://www.googleapis.com/youtube/v3/search');
4406
0
print "$_ " foreach @curlcmd;
4407
0
print "\n";
4408
0
state $tprocess;
4409
$tprocess = MHFS::Process->new(\@curlcmd, $evp, {
4410
'SIGCHLD' => sub {
4411
0
0
my $stdout = $tprocess->{'fd'}{'stdout'}{'fd'};
4412
0
my $buf;
4413
0
while(length($tosend) == 0) {
4414
0
while(read($stdout, $buf, 24000)) {
4415
0
say "did read sigchld";
4416
0
$tosend .= $buf;
4417
}
4418
}
4419
0
undef $tprocess;
4420
0
0
$request->{'qs'}{'fmt'} //= 'html';
4421
0
0
if($request->{'qs'}{'fmt'} eq 'json'){
4422
0
$request->SendBytes('application/json', $tosend);
4423
}
4424
else {
4425
0
$self->sendAsHTML($request, $tosend);
4426
}
4427
},
4428
0
});
4429
0
$request->{'process'} = $tprocess;
4430
0
return -1;
4431
}
4432
4433
sub downloadAndServe {
4434
0
0
my ($self, $request, $video) = @_;
4435
0
weaken($request);
4436
4437
4438
0
my $filename = $video->{'out_filepath'};
4439
my $sendit = sub {
4440
# we can send the file
4441
0
0
0
if(! $request) {
4442
0
return;
4443
}
4444
0
say "sending!!!!";
4445
0
$request->SendLocalFile($filename);
4446
0
};
4447
4448
0
my $qs = $request->{'qs'};
4449
0
0
my @cmd = ($self->{'youtube-dl'}, '--no-part', '--print-traffic', '-f', $self->{'fmts'}{$qs->{"media"} // "video"} // "best", '-o', $video->{"out_filepath"}, '--', $qs->{"id"});
0
4450
$request->{'process'} = MHFS::Process->new_cmd_process($request->{'client'}{'server'}{'evp'}, \@cmd, {
4451
'on_stdout_data' => sub {
4452
0
0
my ($context) = @_;
4453
4454
# determine the size of the file
4455
# relies on receiving content-length header last
4456
0
my ($cl) = $context->{'stdout'} =~ /^.*Content\-Length:\s(\d+)/s;
4457
0
0
return 1 if(! $cl);
4458
0
my ($cr) = $context->{'stdout'} =~ /^.*Content\-Range:\sbytes\s\d+\-\d+\/(\d+)/s;
4459
0
0
if($cr) {
4460
0
say "cr $cr";
4461
0
0
$cl = $cr if($cr > $cl);
4462
}
4463
0
say "cl is $cl";
4464
0
UNLOCK_WRITE($filename);
4465
0
LOCK_WRITE($filename, $cl);
4466
4467
# make sure the file exists and within our parameters
4468
0
my $st = stat($filename);
4469
0
0
$st or return;
4470
0
my $minsize = 16384;
4471
0
0
$minsize = $cl if($cl < $minsize);
4472
0
0
return if($st->size < $minsize);
4473
0
say "sending, currentsize " . $st->size . ' totalsize ' . $cl;
4474
4475
# dont need to check the new data anymore
4476
0
$context->{'on_stdout_data'} = undef;
4477
0
$sendit->();
4478
0
$request = undef;
4479
},
4480
'at_exit' => sub {
4481
0
0
my ($context) = @_;
4482
0
UNLOCK_WRITE($filename);
4483
# last ditch effort, try to send it if we haven't
4484
0
$sendit->();
4485
}
4486
0
});
4487
0
return 1;
4488
}
4489
4490
sub getOutBase {
4491
0
0
my ($self, $qs) = @_;
4492
0
0
return undef if(! $qs->{'id'});
4493
4494
0
my $media;
4495
0
0
0
if(defined $qs->{'media'} && (defined $self->{'fmts'}{$qs->{'media'}})) {
4496
0
$media = $qs->{'media'};
4497
}
4498
else {
4499
0
$media = 'video';
4500
}
4501
0
return $qs->{'id'} . '_' . $media;
4502
}
4503
4504
sub new {
4505
0
0
my ($class, $settings, $server) = @_;
4506
0
my $self = {'settings' => $settings};
4507
0
bless $self, $class;
4508
4509
$self->{'routes'} = [
4510
['/youtube', sub {
4511
0
0
my ($request) = @_;
4512
0
$self->onYoutube($request);
4513
}],
4514
4515
['/yt', sub {
4516
0
0
my ($request) = @_;
4517
0
$self->onYoutube($request);
4518
}],
4519
4520
['/ytmusic', sub {
4521
0
0
my ($request) = @_;
4522
0
0
$request->{'qs'}{'media'} //= 'music';
4523
0
$self->onYoutube($request);
4524
}],
4525
4526
['/ytaudio', sub {
4527
0
0
my ($request) = @_;
4528
0
0
$request->{'qs'}{'media'} //= 'music';
4529
0
$self->onYoutube($request);
4530
}],
4531
['/ytplayer', sub {
4532
0
0
my ($request) = @_;
4533
0
my $html = $self->searchbox($request);
4534
0
$html .= $self->ytplayer($request);
4535
0
$request->SendHTML($html);
4536
}],
4537
['/ytembedplayer', sub {
4538
0
0
my ($request) = @_;
4539
0
$request->SendHTML($self->ytplayer($request));
4540
0
}],
4541
];
4542
4543
0
$self->{'fmts'} = {'music' => 'bestaudio', 'video' => 'best'};
4544
0
$self->{'minsize'} = '1048576';
4545
0
say __PACKAGE__.': adding video format yt';
4546
0
$server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}{'VIDEOFORMATS'}{yt} = {'lock' => 1, 'ext' => 'yt', 'plugin' => $self};
4547
4548
0
my $pstart = __PACKAGE__.": ";
4549
4550
# check for youtube-dl and install if not specified
4551
0
my $youtubedl = $settings->{'Youtube'}{'youtube-dl'};
4552
0
my $installed;
4553
0
0
if(!$youtubedl) {
0
4554
0
my $mhfsytdl = $settings->{'GENERIC_TMPDIR'}.'/youtube-dl';
4555
0
0
if(! -e $mhfsytdl) {
4556
0
say $pstart."Attempting to download youtube-dl";
4557
0
0
if(system('curl', '-L', 'https://yt-dl.org/downloads/latest/youtube-dl', '-o', $mhfsytdl) != 0) {
4558
0
say $pstart . "Failed to download youtube-dl. plugin load failed";
4559
0
return undef;
4560
}
4561
0
0
if(system('chmod', 'a+rx', $mhfsytdl) != 0) {
4562
0
say $pstart . "Failed to set youtube-dl permissions. plugin load failed";
4563
0
return undef;
4564
}
4565
0
$installed = 1;
4566
0
say $pstart."youtube-dl successfully installed!";
4567
}
4568
0
$youtubedl = $mhfsytdl;
4569
}
4570
elsif( ! -e $youtubedl) {
4571
0
say $pstart . "youtube-dl not found. plugin load failed";
4572
0
return undef;
4573
}
4574
0
$self->{'youtube-dl'} = $youtubedl;
4575
4576
# update if we didn't just install
4577
0
0
if(! $installed) {
4578
0
say $pstart . "Attempting to update youtube-dl";
4579
0
0
if(fork() == 0)
4580
{
4581
0
system "$youtubedl", "-U";
4582
0
exit 0;
4583
}
4584
}
4585
4586
0
return $self;
4587
}
4588
4589
1;
4590
}
4591
4592
package MHFS::Plugin::BitTorrent::Tracker {
4593
1
1
9
use strict; use warnings;
1
1
3
1
22
1
5
1
2
1
76
4594
1
1
8
use feature 'say';
1
2
1
77
4595
1
1
15
use Time::HiRes qw( clock_gettime CLOCK_MONOTONIC);
1
3
1
10
4596
MHFS::BitTorrent::Bencoding->import();
4597
1
1
163
use Data::Dumper;
1
2
1
2074
4598
4599
sub createTorrent {
4600
0
0
my ($self, $request) = @_;
4601
0
my $fileitem = $self->{fs}->lookup($request->{'qs'}{'name'}, $request->{'qs'}{'sid'});
4602
0
0
if(!$fileitem) {
4603
0
$request->Send404;
4604
0
return;
4605
}
4606
0
my $absurl = $request->getAbsoluteURL;
4607
0
0
if(! $absurl) {
4608
0
say 'unable to $request->getAbsoluteURL';
4609
0
$request->Send404;
4610
}
4611
0
print Dumper($fileitem);
4612
0
my $outputname = $self->{'settings'}{'MHFS_TRACKER_TORRENT_DIR'}.'/'.$fileitem->{'name'}.'.torrent';
4613
my %maketorrent = ( private => 1,
4614
dest_metafile => $outputname,
4615
src => $fileitem->{filepath},
4616
0
tracker => $absurl.'/torrent/tracker');
4617
0
my $server = $request->{'client'}{'server'};
4618
0
my $evp = $server->{'evp'};
4619
MHFS::BitTorrent::Metainfo::Create($evp, \%maketorrent, sub {
4620
4621
0
0
my $torrentData = MHFS::Util::read_file($outputname);
4622
0
0
if(!$torrentData) {
4623
0
$request->Send404;
4624
}
4625
0
my $torrent = MHFS::BitTorrent::Metainfo::Parse(\$torrentData);
4626
0
0
if(! $torrent) {
4627
0
$request->Send404; return;
0
4628
}
4629
0
my $asciihash = $torrent->InfohashAsHex();
4630
0
say "asciihash: $asciihash";
4631
0
0
$self->{'torrents'}{pack('H*', $asciihash)} //= {};
4632
4633
MHFS::BitTorrent::Client::torrent_start($server, \$torrentData, $fileitem->{'containingdir'}, {
4634
'on_success' => sub {
4635
0
$request->{'responseopt'}{'cd_file'} = 'attachment';
4636
0
$request->SendLocalFile($outputname, 'applications/x-bittorrent');
4637
},
4638
'on_failure' => sub {
4639
0
$request->Send404;
4640
}
4641
0
})});
0
4642
}
4643
4644
sub announce_error {
4645
0
0
my ($message) = @_;
4646
0
return ['d', ['bstr', 'failure reason'], ['bstr', $message]];
4647
}
4648
4649
sub peertostring {
4650
0
0
my ($peer) = @_;
4651
0
my @pvals = unpack('CCCCCC', $peer);
4652
0
return "$pvals[0].$pvals[1].$pvals[2].$pvals[3]:" . (($pvals[4] << 8) | $pvals[5]);
4653
}
4654
4655
sub removeTorrentPeer {
4656
0
0
my ($self, $infohash, $peer, $reason) = @_;
4657
0
say __PACKAGE__.": removing torrent peer ".peertostring($peer). " - $reason";
4658
0
delete $self->{torrents}{$infohash}{$peer};
4659
}
4660
4661
sub announce {
4662
0
0
my ($self, $request) = @_;
4663
4664
# hide the tracker if the required parameters aren't there
4665
0
foreach my $key ('port', 'left', 'info_hash') {
4666
0
0
if(! exists $request->{'qs'}{$key}) {
4667
0
say __PACKAGE__.": missing $key";
4668
0
$request->Send404;
4669
0
return;
4670
}
4671
}
4672
4673
0
my $dictref;
4674
0
while(1) {
4675
0
my $port = $request->{'qs'}{'port'};
4676
0
0
if($port ne unpack('S', pack('S', $port))) {
4677
0
$dictref = announce_error("bad port");
4678
0
last;
4679
}
4680
0
my $left = $request->{'qs'}{'left'};
4681
0
0
if($left ne unpack('Q', pack('Q', $left))) {
4682
0
$dictref = announce_error("bad left");
4683
0
last;
4684
}
4685
0
0
0
if(exists $request->{'qs'}{'compact'} && ($request->{'qs'}{'compact'} eq '0')) {
4686
0
$dictref = announce_error("Only compact responses supported!");
4687
0
last;
4688
}
4689
4690
0
my $rih = $request->{'qs'}{'info_hash'};
4691
0
0
if(!exists $self->{torrents}{$rih}) {
4692
0
$dictref = announce_error("The torrent does not exist!");
4693
0
last;
4694
}
4695
4696
0
my $ip = $request->{'ip'};
4697
0
my $ipport = pack('Nn', $ip, $port);
4698
0
say __PACKAGE__.": announce from ".peertostring($ipport);
4699
4700
4701
0
my $event = $request->{'qs'}{'event'};
4702
#if( (! exists $self->{torrents}{$rih}{$ipport}) &&
4703
#((! defined $event) || ($event ne 'started'))) {
4704
# $dictref = announce_error("first announce must include started event");
4705
# last;
4706
#}
4707
4708
0
0
if($left == 0) {
4709
0
$self->{torrents}{$rih}{$ipport}{'completed'} = 1;
4710
}
4711
4712
0
$self->{torrents}{$rih}{$ipport}{'last_announce'} = clock_gettime(CLOCK_MONOTONIC);
4713
4714
0
0
if(defined $event) {
4715
0
say __PACKAGE__.": announce event $event";
4716
0
0
if($event eq 'started') {
0
0
4717
#$self->{torrents}{$rih}{$ipport} = {'exists' => 1};
4718
}
4719
elsif($event eq 'stopped') {
4720
0
$self->removeTorrentPeer($rih, $ipport, " received stopped message");
4721
}
4722
elsif($event eq 'completed') {
4723
#$self->{torrents}{$rih}{$ipport}{'completed'} = 1;
4724
}
4725
}
4726
4727
0
my $numwant = $request->{'qs'}{'numwant'};
4728
0
0
0
if((! defined $numwant) || ($numwant ne unpack('C', pack('C', $numwant))) || ($numwant > 55)) {
0
4729
0
$numwant = 50;
4730
}
4731
4732
0
my @dict = ('d');
4733
0
push @dict, ['bstr', 'interval'], ['int', $self->{'announce_interval'}];
4734
0
my $complete = 0;
4735
0
my $incomplete = 0;
4736
0
my $pstr = '';
4737
0
my $i = 0;
4738
0
foreach my $peer (keys %{$self->{torrents}{$rih}}) {
0
4739
0
0
if($self->{torrents}{$rih}{$peer}{'completed'}) {
4740
0
$complete++;
4741
}
4742
else {
4743
0
$incomplete++;
4744
}
4745
0
0
if($i++ < $numwant) {
4746
0
0
if($peer ne $ipport) {
4747
0
my @values = unpack('CCCCCC', $peer);
4748
0
my $netmap = $request->{'client'}{'server'}{'settings'}{'NETMAP'};
4749
0
my $pubip = $request->{'client'}{'server'}{'settings'}{'PUBLICIP'};
4750
0
0
0
if($netmap && (($values[0] == $netmap->[1]) && (unpack('C', $ipport) != $netmap->[1])) && $pubip) {
0
0
4751
0
say "HACK converting local peer to public ip";
4752
0
$peer = pack('Nn', MHFS::Util::ParseIPv4($pubip), (($values[4] << 8) | $values[5]));
4753
}
4754
0
say __PACKAGE__.": sending peer ".peertostring($peer);
4755
0
$pstr .= $peer;
4756
}
4757
}
4758
}
4759
#push @dict, ['bstr', 'complete'], ['int', $complete];
4760
#push @dict, ['bstr', 'incomplete'], ['int', $incomplete];
4761
0
push @dict, ['bstr', 'peers'], ['bstr', $pstr];
4762
4763
0
$dictref = \@dict;
4764
0
last;
4765
}
4766
4767
# bencode and send
4768
0
my $bdata = bencode($dictref);
4769
0
0
if($bdata) {
4770
0
$request->SendBytes('text/plain', $bdata);
4771
}
4772
else {
4773
0
say "Critical: Failed to bencode!";
4774
0
$request->Send404;
4775
}
4776
}
4777
4778
sub new {
4779
0
0
my ($class, $settings, $server) = @_;
4780
0
0
0
my $ai = ($settings->{'BitTorrent::Tracker'} && $settings->{'BitTorrent::Tracker'}{'announce_interval'}) ? $settings->{'BitTorrent::Tracker'}{'announce_interval'} : undef;
4781
0
0
$ai //= 1800;
4782
4783
0
my $self = {'settings' => $settings, 'torrents' => \%{$settings->{'TORRENTS'}}, 'announce_interval' => $ai, 'fs' => $server->{'fs'}};
0
4784
0
bless $self, $class;
4785
0
say __PACKAGE__.": announce interval: ".$self->{'announce_interval'};
4786
4787
# load the existing torrents
4788
0
my $odres = opendir(my $tdh, $settings->{'MHFS_TRACKER_TORRENT_DIR'});
4789
0
0
if(! $odres){
4790
0
say __PACKAGE__.":failed to open torrent dir";
4791
0
return undef;
4792
}
4793
0
while(my $file = readdir($tdh)) {
4794
0
0
next if(substr($file, 0, 1) eq '.');
4795
0
my $fullpath = $settings->{'MHFS_TRACKER_TORRENT_DIR'}."/$file";
4796
0
my $torrentcontents = MHFS::Util::read_file($fullpath);
4797
0
0
if(! $torrentcontents) {
4798
0
say __PACKAGE__.": error reading $fullpath";
4799
0
return undef;
4800
}
4801
0
my $torrent = MHFS::BitTorrent::Metainfo::Parse(\$torrentcontents);
4802
0
0
if(! $torrent) {
4803
0
say __PACKAGE__.": error parsing $fullpath";
4804
0
return undef;
4805
}
4806
0
$self->{'torrents'}{$torrent->{'infohash'}} = {};
4807
0
say __PACKAGE__.": added torrent ".$torrent->InfohashAsHex() . ' '.$file;
4808
}
4809
4810
$self->{'routes'} = [
4811
['/torrent/tracker', sub {
4812
0
0
my ($request) = @_;
4813
0
$self->announce($request);
4814
}],
4815
['/torrent/create', sub {
4816
0
0
my ($request) = @_;
4817
0
$self->createTorrent($request);
4818
0
}],
4819
];
4820
4821
$self->{'timers'} = [
4822
# once an hour evict peers that left the swarm ungracefully
4823
[0, 3600, sub {
4824
0
0
my ($timer, $current_time, $evp) = @_;
4825
0
say __PACKAGE__.": evict peers timer";
4826
0
foreach my $infohash (keys %{$self->{'torrents'}}) {
0
4827
0
foreach my $peer (keys %{$self->{'torrents'}{$infohash}}) {
0
4828
0
my $peerdata = $self->{'torrents'}{$infohash}{$peer};
4829
0
0
if(($current_time - $peerdata->{'last_announce'}) > ($self->{'announce_interval'}+60)) {
4830
0
$self->removeTorrentPeer($infohash, $peer, " timeout");
4831
}
4832
}
4833
}
4834
0
return 1;
4835
0
}],
4836
];
4837
4838
0
return $self;
4839
}
4840
4841
1;
4842
}
4843
4844
package MHFS::Plugin::BitTorrent::Client::Interface {
4845
1
1
8
use strict; use warnings;
1
1
2
1
19
1
5
1
2
1
37
4846
1
1
5
use feature 'say';
1
3
1
72
4847
MHFS::Util->import(qw(escape_html do_multiples get_SI_size));
4848
1
1
16
use URI::Escape qw(uri_escape);
1
3
1
1887
4849
4850
sub is_video {
4851
0
0
my ($name) = @_;
4852
0
my ($ext) = $name =~ /\.(mkv|avi|mp4|webm|flv|ts|mpeg|mpg|m2t|m2ts|wmv)$/i;
4853
0
return $ext;
4854
}
4855
4856
sub is_mhfs_music_playable {
4857
0
0
my ($name) = @_;
4858
0
return $name =~ /\.(?:flac|mp3|wav)$/i;
4859
}
4860
4861
sub play_in_browser_link {
4862
0
0
my ($file, $urlfile) = @_;
4863
0
0
return 'HLS (Watch in browser) ' if(is_video($file));
4864
0
0
return 'Play in MHFS Music ' if(is_mhfs_music_playable($file));
4865
0
return 'N/A';
4866
}
4867
4868
sub torrentview {
4869
0
0
my ($request) = @_;
4870
0
my $qs = $request->{'qs'};
4871
0
my $server = $request->{'client'}{'server'};
4872
0
my $evp = $server->{'evp'};
4873
# dump out the status, if the torrent's infohash is provided
4874
0
0
if(defined $qs->{'infohash'}) {
4875
0
my $hash = $qs->{'infohash'};
4876
do_multiples({
4877
0
0
'bytes_done' => sub { MHFS::BitTorrent::Client::torrent_d_bytes_done($server, $hash, @_); },
4878
0
0
'size_bytes' => sub { MHFS::BitTorrent::Client::torrent_d_size_bytes($server, $hash, @_); },
4879
0
0
'name' => sub { MHFS::BitTorrent::Client::torrent_d_name($server, $hash, @_); },
4880
}, sub {
4881
0
0
0
if( ! defined $_[0]) { $request->Send404; return;}
0
0
4882
0
my ($data) = @_;
4883
0
my $torrent_raw = $data->{'name'};
4884
0
my $bytes_done = $data->{'bytes_done'};
4885
0
my $size_bytes = $data->{'size_bytes'};
4886
# print out the current torrent status
4887
0
my $torrent_name = ${escape_html($torrent_raw)};
0
4888
0
my $size_print = get_SI_size($size_bytes);
4889
0
my $done_print = get_SI_size($bytes_done);
4890
0
my $percent_print = (sprintf "%u%%", ($bytes_done/$size_bytes)*100);
4891
0
my $buf = 'Torrent ';
4892
0
$buf .= '';
4893
0
$buf .= '';
4894
0
$buf .= 'Name Size Done Downloaded
4895
0
$buf .= " $torrent_name $size_print $percent_print $done_print
4896
0
$buf .= '
';
4897
4898
# Assume we are downloading, if the bytes don't match
4899
0
0
if($bytes_done < $size_bytes) {
4900
0
$buf .= '
4901
0
$request->SendHTML($buf);
4902
}
4903
else {
4904
# print out the files with usage options
4905
MHFS::BitTorrent::Client::torrent_file_information($server, $qs->{'infohash'}, $torrent_raw, sub {
4906
0
0
if(! defined $_[0]){ $request->Send404; return; };
0
0
4907
0
my ($tfi) = @_;
4908
0
my @files = sort (keys %$tfi);
4909
0
$buf .= '
4910
0
$buf .= '';
4911
0
$buf .= 'File Size DL Play in browser
4912
0
$buf .= '
4913
0
foreach my $file (@files) {
4914
0
my $htmlfile = ${escape_html($file)};
0
4915
0
my $urlfile = uri_escape($file);
4916
0
my $link = 'DL ';
4917
0
my $playlink = play_in_browser_link($file, $urlfile);
4918
0
$buf .= " $htmlfile " . get_SI_size($tfi->{$file}{'size'}) . " $link ";
4919
0
0
0
$buf .= " $playlink " if(!defined($qs->{'playinbrowser'}) || ($qs->{'playinbrowser'} == 1));
4920
0
$buf .= " ";
4921
}
4922
0
$buf .= '
4923
0
$buf .= '
';
4924
4925
0
$request->SendHTML($buf);
4926
0
});
4927
}
4928
4929
0
});
4930
}
4931
else {
4932
MHFS::BitTorrent::Client::torrent_list_torrents($server, sub{
4933
0
0
0
if(! defined $_[0]){ $request->Send404; return; };
0
0
4934
0
my ($rtresponse) = @_;
4935
0
my @lines = split( /\n/, $rtresponse);
4936
0
my $buf = 'Torrents ';
4937
0
$buf .= '';
4938
0
$buf .= '';
4939
0
$buf .= 'Name Hash Size Done Private
4940
0
$buf .= " ";
4941
0
my $curtor = '';
4942
0
while(1) {
4943
0
0
if($curtor =~ /^\[(u?)['"](.+)['"],\s'(.+)',\s([0-9]+),\s([0-9]+),\s([0-9]+)\]$/) {
4944
0
my %torrent;
4945
0
my $is_unicode = $1;
4946
0
$torrent{'name'} = $2;
4947
0
$torrent{'hash'} = $3;
4948
0
$torrent{'size_bytes'} = $4;
4949
0
$torrent{'bytes_done'} = $5;
4950
0
$torrent{'private'} = $6;
4951
0
0
if($is_unicode) {
4952
0
my $escaped_unicode = $torrent{'name'};
4953
0
$torrent{'name'} =~ s/\\u(.{4})/chr(hex($1))/eg;
0
4954
0
$torrent{'name'} =~ s/\\x(.{2})/chr(hex($1))/eg;
0
4955
0
my $decoded_as = $torrent{'name'};
4956
0
$torrent{'name'} = ${escape_html($torrent{'name'})};
0
4957
0
0
if($qs->{'logunicode'}) {
4958
0
say 'unicode escaped: ' . $escaped_unicode;
4959
0
say 'decoded as: ' . $decoded_as;
4960
0
say 'html escaped ' . $torrent{'name'};
4961
}
4962
}
4963
0
$buf .= ' ' . $torrent{'name'} . ' ' . $torrent{'hash'} . ' ' . $torrent{'size_bytes'} . ' ' . $torrent{'bytes_done'} . ' ' . $torrent{'private'} . '
4964
0
$curtor = '';
4965
}
4966
else {
4967
0
my $line = shift @lines;
4968
0
0
if(! $line) {
4969
0
last;
4970
}
4971
0
$curtor .= $line;
4972
}
4973
}
4974
0
$buf .= '
';
4975
0
$request->SendHTML($buf);
4976
0
});
4977
}
4978
}
4979
4980
sub torrentload {
4981
0
0
my ($request) = @_;
4982
0
my $packagename = __PACKAGE__;
4983
0
my $self = $request->{'client'}{server}{'loaded_plugins'}{$packagename};
4984
4985
0
0
0
if((exists $request->{'qs'}{'dlsubsystem'}) && (exists $request->{'qs'}{'privdata'}) ) {
4986
0
my $subsystem = $request->{'qs'}{'dlsubsystem'};
4987
0
0
if(exists $self->{'dlsubsystems'}{$subsystem}) {
4988
0
my $server = $request->{'client'}{'server'};
4989
$self->{'dlsubsystems'}{$subsystem}->dl($server, $request->{'qs'}{'privdata'}, sub {
4990
0
0
my ($result, $destdir) = @_;
4991
0
0
if(! $result) {
4992
0
say "failed to dl torrent";
4993
0
$request->Send404;
4994
0
return;
4995
}
4996
MHFS::BitTorrent::Client::torrent_start($server, \$result, $destdir, {
4997
'on_success' => sub {
4998
0
my ($hexhash) = @_;
4999
0
$request->SendRedirectRawURL(301, 'view?infohash=' . $hexhash);
5000
},
5001
'on_failure' => sub {
5002
0
$request->Send404;
5003
}
5004
0
});
5005
0
});
5006
0
return;
5007
}
5008
}
5009
0
$request->Send404;
5010
}
5011
5012
sub new {
5013
0
0
my ($class, $settings) = @_;
5014
0
my $self = { 'dlsubsystems' => {}};
5015
0
bless $self, $class;
5016
5017
0
$self->{'routes'} = [
5018
[ '/torrent/view', \&torrentview ],
5019
[ '/torrent/load', \&torrentload ]
5020
];
5021
5022
0
return $self;
5023
}
5024
5025
1;
5026
}
5027
5028
package MHFS::Plugin::OpenDirectory {
5029
1
1
10
use strict; use warnings;
1
1
2
1
32
1
6
1
3
1
28
5030
1
1
5
use feature 'say';
1
2
1
312
5031
5032
sub new {
5033
0
0
my ($class, $settings) = @_;
5034
0
my $self = {};
5035
0
bless $self, $class;
5036
5037
0
my $odmappings = $settings->{OPENDIRECTORY}{maps};
5038
5039
$self->{'routes'} = [
5040
[
5041
'/od', sub {
5042
0
0
my ($request) = @_;
5043
0
$request->SendRedirect(301, 'od/');
5044
}
5045
],
5046
[
5047
'/od/*', sub {
5048
0
0
my ($request) = @_;
5049
0
foreach my $key (keys %{$odmappings}) {
0
5050
0
0
if(rindex($request->{'path'}{'unsafepath'}, '/od/'.$key, 0) == 0) {
5051
0
$request->SendDirectoryListing($odmappings->{$key}, '/od/'.$key);
5052
0
return;
5053
}
5054
}
5055
0
$request->Send404;
5056
}
5057
0
],
5058
];
5059
5060
0
return $self;
5061
}
5062
5063
1;
5064
}
5065
5066
package MHFS::Plugin::Playlist {
5067
1
1
7
use strict; use warnings;
1
1
2
1
21
1
4
1
2
1
34
5068
1
1
6
use feature 'say';
1
10
1
85
5069
1
1
7
use Data::Dumper;
1
2
1
49
5070
1
1
7
use URI::Escape qw(uri_escape);
1
3
1
49
5071
1
1
7
use Encode qw(decode);
1
3
1
765
5072
5073
sub video_get_m3u8 {
5074
0
0
my ($video, $urlstart) = @_;
5075
0
my $buf;
5076
0
my $m3u8 = <<'M3U8END';
5077
#EXTM3U
5078
#EXTVLCOPT:network-caching=40000'
5079
M3U8END
5080
5081
0
my @files;
5082
0
0
if(! -d $video->{'src_file'}{'filepath'}) {
5083
0
push @files, $video->{'src_file'}{'fullname'};
5084
}
5085
else {
5086
output_dir_versatile($video->{'src_file'}{'filepath'}, {
5087
'root' => $video->{'src_file'}{'root'},
5088
'on_file' => sub {
5089
0
0
my ($path, $shortpath) = @_;
5090
0
push @files, $shortpath;
5091
}
5092
0
});
5093
}
5094
5095
0
foreach my $file (@files) {
5096
0
$m3u8 .= '#EXTINF:0, ' . decode('UTF-8', $file, Encode::LEAVE_SRC) . "\n";
5097
0
$m3u8 .= $urlstart . uri_escape($file) . "\n";
5098
#$m3u8 .= $urlstart . small_url_encode($file) . "\n";
5099
}
5100
0
return \$m3u8;
5101
}
5102
5103
sub new {
5104
0
0
my ($class, $settings, $server) = @_;
5105
0
my $self = {};
5106
0
bless $self, $class;
5107
5108
0
my @subsystems = ('video');
5109
5110
$self->{'routes'} = [
5111
[
5112
'/playlist/*', sub {
5113
0
0
my ($request) = @_;
5114
0
my $qs = $request->{'qs'};
5115
0
my @pathcomponents = split('/', $request->{'path'}{'unsafepath'});
5116
0
0
if(scalar(@pathcomponents) >= 3) {
5117
0
0
if($pathcomponents[2] eq 'video') {
5118
0
0
if(scalar(@pathcomponents) >= 5) {
5119
0
0
my %video = ('out_fmt' => ($request->{'qs'}{'vfmt'} // 'noconv'));
5120
0
my $sid = $pathcomponents[3];
5121
0
splice(@pathcomponents, 0, 4);
5122
0
my $nametolookup = join('/', @pathcomponents);
5123
0
$video{'src_file'} = $server->{'fs'}->lookup($nametolookup, $sid);
5124
0
0
if( ! $video{'src_file'} ) {
5125
0
$request->Send404;
5126
0
return undef;
5127
}
5128
0
$video{'out_base'} = $video{'src_file'}{'name'};
5129
0
0
my $fmt = $request->{'qs'}{'fmt'} // 'm3u8';
5130
0
0
if($fmt eq 'm3u8') {
5131
0
my $absurl = $request->getAbsoluteURL;
5132
0
0
if(! $absurl) {
5133
0
say 'unable to $request->getAbsoluteURL';
5134
0
$request->Send404;
5135
0
return undef;
5136
}
5137
0
my $m3u8 = video_get_m3u8(\%video, $absurl . '/get_video?sid='. $sid . '&name=');
5138
0
0
$video{'src_file'}{'ext'} = $video{'src_file'}{'ext'} ? '.'. $video{'src_file'}{'ext'} : '';
5139
0
$request->{'responseopt'}{'cd_file'} = 'inline';
5140
0
$request->SendText('application/x-mpegURL', $$m3u8, {'filename' => $video{'src_file'}{'name'} . $video{'src_file'}{'ext'} . '.m3u8'});
5141
0
return 1;
5142
}
5143
}
5144
}
5145
}
5146
0
$request->Send404;
5147
}
5148
0
],
5149
];
5150
5151
0
return $self;
5152
}
5153
5154
1;
5155
}
5156
5157
package MHFS::Plugin::Kodi {
5158
1
1
8
use strict; use warnings;
1
1
2
1
22
1
5
1
2
1
34
5159
1
1
6
use feature 'say';
1
2
1
67
5160
1
1
8
use File::Basename qw(basename);
1
2
1
51
5161
1
1
5
use Cwd qw(abs_path);
1
2
1
50
5162
1
1
6
use URI::Escape qw(uri_escape);
1
2
1
39
5163
1
1
6
use Encode qw(decode);
1
3
1
2281
5164
5165
# format tv library for kodi http
5166
sub route_tv {
5167
0
0
my ($request, $absdir, $kodidir) = @_;
5168
# read in the shows
5169
0
my $tvdir = abs_path($absdir);
5170
0
0
if(! defined $tvdir) {
5171
0
$request->Send404;
5172
0
return;
5173
}
5174
0
my $dh;
5175
0
0
if(! opendir ( $dh, $tvdir )) {
5176
0
warn "Error in opening dir $tvdir\n";
5177
0
$request->Send404;
5178
0
return;
5179
}
5180
0
my %shows = ();
5181
0
my @diritems;
5182
0
while( (my $filename = readdir($dh))) {
5183
0
0
0
next if(($filename eq '.') || ($filename eq '..'));
5184
0
0
next if(!(-s "$tvdir/$filename"));
5185
# extract the showname
5186
0
0
next if($filename !~ /^(.+)[\.\s]+S\d+/);
5187
0
my $showname = $1;
5188
0
0
if($showname) {
5189
0
$showname =~ s/\./ /g;
5190
0
0
if(! $shows{$showname}) {
5191
0
$shows{$showname} = [];
5192
0
push @diritems, {'item' => $showname, 'isdir' => 1}
5193
}
5194
0
push @{$shows{$showname}}, "$tvdir/$filename";
0
5195
}
5196
}
5197
0
closedir($dh);
5198
5199
# locate the content
5200
0
0
if($request->{'path'}{'unsafepath'} ne $kodidir) {
5201
0
my $fullshowname = substr($request->{'path'}{'unsafepath'}, length($kodidir)+1);
5202
0
my $slash = index($fullshowname, '/');
5203
0
@diritems = ();
5204
0
0
my $showname = ($slash != -1) ? substr($fullshowname, 0, $slash) : $fullshowname;
5205
0
0
my $showfilename = ($slash != -1) ? substr($fullshowname, $slash+1) : undef;
5206
5207
0
my $showitems = $shows{$showname};
5208
0
0
if(!$showitems) {
5209
0
$request->Send404;
5210
0
return;
5211
}
5212
0
my @initems = @{$showitems};
0
5213
0
my @outitems;
5214
# TODO replace basename usage?
5215
0
while(@initems) {
5216
0
my $item = shift @initems;
5217
0
$item = abs_path($item);
5218
0
0
if(! $item) {
0
0
0
5219
0
say "bad item";
5220
}
5221
elsif(rindex($item, $tvdir, 0) != 0) {
5222
0
say "bad item, path traversal?";
5223
}
5224
elsif(-f $item) {
5225
0
my $filebasename = basename($item);
5226
0
0
if(!$showfilename) {
0
5227
0
push @diritems, {'item' => $filebasename, 'isdir' => 0};
5228
}
5229
elsif($showfilename eq $filebasename) {
5230
0
0
if(index($request->{'path'}{'unsafecollapse'}, '/', length($request->{'path'}{'unsafecollapse'})-1) == -1) {
5231
0
say "found show filename";
5232
0
$request->SendFile($item);
5233
}
5234
else {
5235
0
$request->Send404;
5236
}
5237
0
return;
5238
}
5239
}
5240
elsif(-d _) {
5241
0
0
opendir(my $dh, $item) or die('failed to open dir');
5242
0
my @newitems;
5243
0
while(my $newitem = readdir($dh)) {
5244
0
0
0
next if(($newitem eq '.') || ($newitem eq '..'));
5245
0
push @newitems, "$item/$newitem";
5246
}
5247
0
closedir($dh);
5248
0
unshift @initems, @newitems;
5249
}
5250
else {
5251
0
say "bad item unknown filetype " . $item;
5252
}
5253
}
5254
}
5255
5256
# redirect if the slash wasn't there
5257
0
0
if(index($request->{'path'}{'unescapepath'}, '/', length($request->{'path'}{'unescapepath'})-1) == -1) {
5258
0
$request->SendRedirect(301, substr($request->{'path'}{'unescapepath'}, rindex($request->{'path'}{'unescapepath'}, '/')+1).'/');
5259
0
return;
5260
}
5261
5262
# generate the directory html
5263
0
my $buf = '';
5264
0
foreach my $show (@diritems) {
5265
0
my $showname = $show->{'item'};
5266
0
my $url = uri_escape($showname);
5267
0
0
$url .= '/' if($show->{'isdir'});
5268
0
$buf .= ''.${MHFS::Util::escape_html_noquote(decode('UTF-8', $showname, Encode::LEAVE_SRC))} .'
0
5269
}
5270
0
$request->SendHTML($buf);
5271
}
5272
5273
# format movies library for kodi http
5274
sub route_movies {
5275
0
0
my ($request, $absdir, $kodidir) = @_;
5276
# read in the shows
5277
0
my $moviedir = abs_path($absdir);
5278
0
0
if(! defined $moviedir) {
5279
0
$request->Send404;
5280
0
return;
5281
}
5282
0
my $dh;
5283
0
0
if(! opendir ( $dh, $moviedir )) {
5284
0
warn "Error in opening dir $moviedir\n";
5285
0
$request->Send404;
5286
0
return;
5287
}
5288
0
my %shows = ();
5289
0
my @diritems;
5290
0
while( (my $filename = readdir($dh))) {
5291
0
0
0
next if(($filename eq '.') || ($filename eq '..'));
5292
0
0
next if(!(-s "$moviedir/$filename"));
5293
0
my $showname;
5294
# extract the showname
5295
0
0
if($filename =~ /^(.+)[\.\s]+\(?(\d{4})([^p]|$)/) {
0
0
0
0
5296
0
$showname = "$1 ($2)";
5297
}
5298
elsif($filename =~ /^(.+)(\.DVDRip)\.[a-zA-Z]{3,4}$/) {
5299
0
$showname = $1;
5300
}
5301
elsif($filename =~ /^(.+)\.VHS/) {
5302
0
$showname = $1;
5303
}
5304
elsif($filename =~ /^(.+)[\.\s]+\d{3,4}p\.[a-zA-Z]{3,4}$/) {
5305
0
$showname = $1;
5306
}
5307
elsif($filename =~ /^(.+)\.[a-zA-Z]{3,4}$/) {
5308
0
$showname = $1;
5309
}
5310
else{
5311
#next;
5312
0
$showname = $filename;
5313
}
5314
0
0
if($showname) {
5315
0
$showname =~ s/\./ /g;
5316
0
0
if(! $shows{$showname}) {
5317
0
$shows{$showname} = [];
5318
0
push @diritems, {'item' => $showname, 'isdir' => 1}
5319
}
5320
0
push @{$shows{$showname}}, "$moviedir/$filename";
0
5321
}
5322
}
5323
0
closedir($dh);
5324
5325
# locate the content
5326
0
0
if($request->{'path'}{'unsafepath'} ne $kodidir) {
5327
0
my $fullshowname = substr($request->{'path'}{'unsafepath'}, length($kodidir)+1);
5328
0
say "fullshowname $fullshowname";
5329
0
my $slash = index($fullshowname, '/');
5330
0
@diritems = ();
5331
0
0
my $showname = ($slash != -1) ? substr($fullshowname, 0, $slash) : $fullshowname;
5332
0
0
my $showfilename = ($slash != -1) ? substr($fullshowname, $slash+1) : undef;
5333
0
say "showname $showname";
5334
5335
0
my $showitems = $shows{$showname};
5336
0
0
if(!$showitems) {
5337
0
$request->Send404;
5338
0
return;
5339
}
5340
0
my @initems = @{$showitems};
0
5341
0
my @outitems;
5342
# TODO replace basename usage?
5343
0
while(@initems) {
5344
0
my $item = shift @initems;
5345
0
$item = abs_path($item);
5346
0
0
if(! $item) {
0
0
0
5347
0
say "bad item";
5348
}
5349
elsif(rindex($item, $moviedir, 0) != 0) {
5350
0
say "bad item, path traversal?";
5351
}
5352
elsif(-f $item) {
5353
0
my $filebasename = basename($item);
5354
0
0
if(!$showfilename) {
0
5355
0
push @diritems, {'item' => $filebasename, 'isdir' => 0};
5356
}
5357
elsif($showfilename eq $filebasename) {
5358
0
0
if(index($request->{'path'}{'unsafecollapse'}, '/', length($request->{'path'}{'unsafecollapse'})-1) == -1) {
5359
0
say "found show filename";
5360
0
$request->SendFile($item);
5361
}
5362
else {
5363
0
$request->Send404;
5364
}
5365
0
return;
5366
}
5367
}
5368
elsif(-d _) {
5369
0
0
opendir(my $dh, $item) or die('failed to open dir');
5370
0
my @newitems;
5371
0
while(my $newitem = readdir($dh)) {
5372
0
0
0
next if(($newitem eq '.') || ($newitem eq '..'));
5373
0
push @newitems, "$item/$newitem";
5374
}
5375
0
closedir($dh);
5376
0
unshift @initems, @newitems;
5377
}
5378
else {
5379
0
say "bad item unknown filetype " . $item;
5380
}
5381
}
5382
}
5383
5384
# redirect if the slash wasn't there
5385
0
0
if(index($request->{'path'}{'unescapepath'}, '/', length($request->{'path'}{'unescapepath'})-1) == -1) {
5386
0
$request->SendRedirect(301, substr($request->{'path'}{'unescapepath'}, rindex($request->{'path'}{'unescapepath'}, '/')+1).'/');
5387
0
return;
5388
}
5389
5390
# generate the directory html
5391
0
my $buf = '';
5392
0
foreach my $show (@diritems) {
5393
0
my $showname = $show->{'item'};
5394
0
my $url = uri_escape($showname);
5395
0
0
$url .= '/' if($show->{'isdir'});
5396
0
$buf .= ''. ${MHFS::Util::escape_html_noquote(decode('UTF-8', $showname, Encode::LEAVE_SRC))} .'
0
5397
}
5398
0
$request->SendHTML($buf);
5399
}
5400
5401
sub new {
5402
0
0
my ($class, $settings) = @_;
5403
0
my $self = {};
5404
0
bless $self, $class;
5405
5406
0
my @subsystems = ('video');
5407
5408
$self->{'routes'} = [
5409
[
5410
'/kodi/*', sub {
5411
0
0
my ($request) = @_;
5412
0
my @pathcomponents = split('/', $request->{'path'}{'unsafepath'});
5413
0
0
if(scalar(@pathcomponents) >= 3) {
5414
0
0
if($pathcomponents[2] eq 'movies') {
0
5415
0
route_movies($request, $settings->{'MEDIALIBRARIES'}{'movies'}, '/kodi/movies');
5416
0
return;
5417
}
5418
elsif($pathcomponents[2] eq 'tv') {
5419
0
route_tv($request, $settings->{'MEDIALIBRARIES'}{'tv'}, '/kodi/tv');
5420
0
return;
5421
}
5422
}
5423
0
$request->Send404;
5424
}
5425
0
],
5426
];
5427
5428
0
return $self;
5429
}
5430
5431
5432
1;
5433
}
5434
5435
package MHFS::Plugin::GetVideo {
5436
1
1
9
use strict; use warnings;
1
1
1
1
30
1
7
1
2
1
28
5437
1
1
5
use feature 'say';
1
2
1
74
5438
1
1
6
use Data::Dumper qw (Dumper);
1
2
1
52
5439
1
1
22
use Fcntl qw(:seek);
1
3
1
148
5440
1
1
7
use Scalar::Util qw(weaken);
1
3
1
74
5441
1
1
8
use URI::Escape qw (uri_escape);
1
2
1
43
5442
1
1
6
use Devel::Peek qw(Dump);
1
2
1
10
5443
1
1
111
no warnings "portable";
1
2
1
57
5444
1
1
6
use Config;
1
2
1
4589
5445
5446
MHFS::Util->import();
5447
5448
sub new {
5449
0
0
my ($class, $settings) = @_;
5450
5451
0
0
if($Config{ivsize} < 8) {
5452
0
warn("Integers are too small!");
5453
0
return undef;
5454
}
5455
5456
0
my $self = {};
5457
0
bless $self, $class;
5458
5459
$self->{'VIDEOFORMATS'} = {
5460
'hls' => {'lock' => 0, 'create_cmd' => sub {
5461
0
0
my ($video) = @_;
5462
0
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"]
5463
}, 'ext' => 'm3u8', 'desired_audio' => 'aac',
5464
'player_html' => $settings->{'DOCUMENTROOT'} . '/static/hls_player.html'},
5465
5466
'jsmpeg' => {'lock' => 0, 'create_cmd' => sub {
5467
0
0
my ($video) = @_;
5468
0
return ['ffmpeg', '-i', $video->{"src_file"}{"filepath"}, '-f', 'mpegts', '-codec:v', 'mpeg1video', '-codec:a', 'mp2', '-b', '0', $video->{"out_filepath"}];
5469
}, 'ext' => 'ts', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/jsmpeg_player.html', 'minsize' => '1048576'},
5470
5471
'mp4' => {'lock' => 1, 'create_cmd' => sub {
5472
0
0
my ($video) = @_;
5473
0
return ['ffmpeg', '-i', $video->{"src_file"}{"filepath"}, '-c:v', 'copy', '-c:a', 'aac', '-f', 'mp4', '-movflags', 'frag_keyframe+empty_moov', $video->{"out_filepath"}];
5474
}, 'ext' => 'mp4', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/mp4_player.html', 'minsize' => '1048576'},
5475
5476
0
'noconv' => {'lock' => 0, 'ext' => '', 'player_html' => $settings->{'DOCUMENTROOT'} . '/static/noconv_player.html', },
5477
5478
'mkvinfo' => {'lock' => 0, 'ext' => ''},
5479
'fmp4' => {'lock' => 0, 'ext' => ''},
5480
};
5481
5482
0
$self->{'routes'} = [
5483
[
5484
'/get_video', \&get_video
5485
],
5486
];
5487
5488
0
return $self;
5489
}
5490
5491
sub get_video {
5492
0
0
my ($request) = @_;
5493
0
say "/get_video ---------------------------------------";
5494
0
my $packagename = __PACKAGE__;
5495
0
my $server = $request->{'client'}{'server'};
5496
0
my $self = $server->{'loaded_plugins'}{$packagename};
5497
0
my $settings = $server->{'settings'};
5498
0
my $videoformats = $self->{VIDEOFORMATS};
5499
0
$request->{'responseopt'}{'cd_file'} = 'inline';
5500
0
my $qs = $request->{'qs'};
5501
0
0
$qs->{'fmt'} //= 'noconv';
5502
0
my %video = ('out_fmt' => $self->video_get_format($qs->{'fmt'}));
5503
0
0
if(defined($qs->{'name'})) {
0
5504
0
0
if(defined($qs->{'sid'})) {
5505
0
$video{'src_file'} = $server->{'fs'}->lookup($qs->{'name'}, $qs->{'sid'});
5506
0
0
if( ! $video{'src_file'} ) {
5507
0
$request->Send404;
5508
0
return undef;
5509
}
5510
}
5511
else {
5512
0
$request->Send404;
5513
0
return undef;
5514
}
5515
0
print Dumper($video{'src_file'});
5516
# no conversion necessary, just SEND IT
5517
0
0
if($video{'out_fmt'} eq 'noconv') {
0
0
5518
0
say "NOCONV: SEND IT";
5519
0
$request->SendFile($video{'src_file'}{'filepath'});
5520
0
return 1;
5521
}
5522
elsif($video{'out_fmt'} eq 'mkvinfo') {
5523
0
get_video_mkvinfo($request, $video{'src_file'}{'filepath'});
5524
0
return 1;
5525
}
5526
elsif($video{'out_fmt'} eq 'fmp4') {
5527
0
get_video_fmp4($request, $video{'src_file'}{'filepath'});
5528
0
return;
5529
}
5530
5531
0
0
if(! -e $video{'src_file'}{'filepath'}) {
5532
0
$request->Send404;
5533
0
return undef;
5534
}
5535
5536
0
$video{'out_base'} = $video{'src_file'}{'name'};
5537
5538
# soon https://github.com/video-dev/hls.js/pull/1899
5539
0
0
$video{'out_base'} = space2us($video{'out_base'}) if ($video{'out_fmt'} eq 'hls');
5540
}
5541
elsif($videoformats->{$video{'out_fmt'}}{'plugin'}) {
5542
0
$video{'plugin'} = $videoformats->{$video{'out_fmt'}}{'plugin'};
5543
0
0
if(!($video{'out_base'} = $video{'plugin'}->getOutBase($qs))) {
5544
0
$request->Send404;
5545
0
return undef;
5546
}
5547
}
5548
else {
5549
0
$request->Send404;
5550
0
return undef;
5551
}
5552
5553
# Determine the full path to the desired file
5554
0
my $fmt = $video{'out_fmt'};
5555
0
$video{'out_location'} = $settings->{'VIDEO_TMPDIR'} . '/' . $video{'out_base'};
5556
0
$video{'out_filepath'} = $video{'out_location'} . '/' . $video{'out_base'} . '.' . $videoformats->{$video{'out_fmt'}}{'ext'};
5557
0
$video{'out_location_url'} = 'get_video?'.$settings->{VIDEO_TMPDIR_QS}.'&fmt=noconv&name='.$video{'out_base'}.'%2F';
5558
5559
# Serve it up if it has been created
5560
0
0
if(-e $video{'out_filepath'}) {
5561
0
say $video{'out_filepath'} . " already exists";
5562
0
$request->SendFile($video{'out_filepath'});
5563
0
return 1;
5564
}
5565
# otherwise create it
5566
0
mkdir($video{'out_location'});
5567
0
0
0
if(($videoformats->{$fmt}{'lock'} == 1) && (LOCK_WRITE($video{'out_filepath'}) != 1)) {
5568
0
say "FAILED to LOCK";
5569
# we should do something here
5570
}
5571
0
0
if($video{'plugin'}) {
0
5572
0
$video{'plugin'}->downloadAndServe($request, \%video);
5573
0
return 1;
5574
}
5575
elsif(defined($videoformats->{$fmt}{'create_cmd'})) {
5576
0
my @cmd = @{$videoformats->{$fmt}{'create_cmd'}->(\%video)};
0
5577
0
print "$_ " foreach @cmd;
5578
0
print "\n";
5579
5580
video_on_streams(\%video, $request, sub {
5581
#say "there should be no pids around";
5582
#$request->Send404;
5583
#return undef;
5584
5585
0
0
0
if($fmt eq 'hls') {
5586
0
$video{'on_exists'} = \&video_hls_write_master_playlist;
5587
}
5588
5589
# deprecated
5590
0
$video{'pid'} = ASYNC(\&shellcmd_unlock, \@cmd, $video{'out_filepath'});
5591
5592
# our file isn't ready yet, so create a timer to check the progress and act
5593
0
weaken($request); # the only one who should be keeping $request alive is the client
5594
$request->{'client'}{'server'}{'evp'}->add_timer(0, 0, sub {
5595
0
0
if(! defined $request) {
5596
0
say "\$request undef, ignoring CB";
5597
0
return undef;
5598
}
5599
# test if its ready to send
5600
0
while(1) {
5601
0
my $filename = $video{'out_filepath'};
5602
0
0
if(! -e $filename) {
5603
0
last;
5604
}
5605
0
my $minsize = $videoformats->{$fmt}{'minsize'};
5606
0
0
0
if(defined($minsize) && ((-s $filename) < $minsize)) {
5607
0
last;
5608
}
5609
0
0
if(defined $video{'on_exists'}) {
5610
0
0
last if (! $video{'on_exists'}->($settings, \%video));
5611
}
5612
0
say "get_video_timer is destructing";
5613
0
$request->SendLocalFile($filename);
5614
0
return undef;
5615
}
5616
# 404, if we didn't send yet the process is not running
5617
0
0
if(pid_running($video{'pid'})) {
5618
0
return 1;
5619
}
5620
0
say "pid not running: " . $video{'pid'} . " get_video_timer done with 404";
5621
0
$request->Send404;
5622
0
return undef;
5623
0
});
5624
0
say "get_video: added timer " . $video{'out_filepath'};
5625
0
});
5626
}
5627
else {
5628
0
say "out_fmt: " . $video{'out_fmt'};
5629
0
$request->Send404;
5630
0
return undef;
5631
}
5632
0
return 1;
5633
}
5634
5635
sub video_get_format {
5636
0
0
my ($self, $fmt) = @_;
5637
5638
0
0
if(defined($fmt)) {
5639
# hack for jsmpeg corrupting the url
5640
0
$fmt =~ s/\?.+$//;
5641
0
0
if(defined $self->{VIDEOFORMATS}{$fmt}) {
5642
0
return $fmt;
5643
}
5644
}
5645
5646
0
return 'noconv';
5647
}
5648
sub video_hls_write_master_playlist {
5649
# Rebuilt the master playlist because reasons; YOU ARE TEARING ME APART, FFMPEG!
5650
0
0
my ($settings, $video) = @_;
5651
0
my $requestfile = $video->{'out_filepath'};
5652
5653
# fix the path to the video playlist to be correct
5654
0
my $m3ucontent = read_file($requestfile);
5655
0
my $subm3u;
5656
0
my $newm3ucontent = '';
5657
0
foreach my $line (split("\n", $m3ucontent)) {
5658
# master playlist doesn't get written with base url ...
5659
0
0
if($line =~ /^(.+)\.m3u8_v$/) {
5660
0
$subm3u = "get_video?".$settings->{VIDEO_TMPDIR_QS}."&fmt=noconv&name=" . uri_escape("$1/$1");
5661
0
$line = $subm3u . '.m3u8_v';
5662
}
5663
0
$newm3ucontent .= $line . "\n";
5664
}
5665
5666
# Always start at 0, even if we encoded half of the movie
5667
#$newm3ucontent .= '#EXT-X-START:TIME-OFFSET=0,PRECISE=YES' . "\n";
5668
5669
# if ffmpeg created a sub include it in the playlist
5670
0
($requestfile =~ /^(.+)\.m3u8$/);
5671
0
my $reqsub = "$1_vtt.m3u8";
5672
0
0
0
if($subm3u && -e $reqsub) {
5673
0
$subm3u .= "_vtt.m3u8";
5674
0
say "subm3u $subm3u";
5675
0
my $default = 'NO';
5676
0
my $forced = 'NO';
5677
0
foreach my $sub (@{$video->{'subtitle'}}) {
0
5678
0
0
$default = 'YES' if($sub->{'is_default'});
5679
0
0
$forced = 'YES' if($sub->{'is_forced'});
5680
}
5681
# assume its in english
5682
0
$newm3ucontent .= '#EXT-X-MEDIA:TYPE=SUBTITLES,GROUP-ID="subs",NAME="English",DEFAULT='.$default.',FORCED='.$forced.',URI="' . $subm3u . '",LANGUAGE="en"' . "\n";
5683
}
5684
0
write_file($requestfile, $newm3ucontent);
5685
0
return 1;
5686
}
5687
5688
sub get_video_mkvinfo {
5689
0
0
my ($request, $fileabspath) = @_;
5690
0
my $matroska = matroska_open($fileabspath);
5691
0
0
if(! $matroska) {
5692
0
$request->Send404;
5693
0
return;
5694
}
5695
5696
0
my $obj;
5697
0
0
if(defined $request->{'qs'}{'mkvinfo_time'}) {
5698
0
my $track = matroska_get_video_track($matroska);
5699
0
0
if(! $track) {
5700
0
$request->Send404;
5701
0
return;
5702
}
5703
0
my $gopinfo = matroska_get_gop($matroska, $track, $request->{'qs'}{'mkvinfo_time'});
5704
0
0
if(! $gopinfo) {
5705
0
$request->Send404;
5706
0
return;
5707
}
5708
0
$obj = $gopinfo;
5709
}
5710
else {
5711
0
$obj = {};
5712
}
5713
0
$obj->{duration} = $matroska->{'duration'};
5714
0
$request->SendAsJSON($obj);
5715
}
5716
5717
sub get_video_fmp4 {
5718
0
0
my ($request, $fileabspath) = @_;
5719
0
my @command = ('ffmpeg', '-loglevel', 'fatal');
5720
0
0
if($request->{'qs'}{'fmp4_time'}) {
5721
0
my $formattedtime = hls_audio_formattime($request->{'qs'}{'fmp4_time'});
5722
0
push @command, ('-ss', $formattedtime);
5723
}
5724
0
push @command, ('-i', $fileabspath, '-c:v', 'copy', '-c:a', 'aac', '-f', 'mp4', '-movflags', 'frag_keyframe+empty_moov', '-');
5725
0
my $evp = $request->{'client'}{'server'}{'evp'};
5726
0
my $sent;
5727
0
print "$_ " foreach @command;
5728
0
$request->{'outheaders'}{'Accept-Ranges'} = 'none';
5729
5730
# avoid bookkeeping, have ffmpeg output straight to the socket
5731
0
$request->{'outheaders'}{'Connection'} = 'close';
5732
0
$request->{'outheaders'}{'Content-Type'} = 'video/mp4';
5733
0
my $sock = $request->{'client'}{'sock'};
5734
0
print $sock "HTTP/1.0 200 OK\r\n";
5735
0
my $headtext = '';
5736
0
foreach my $header (keys %{$request->{'outheaders'}}) {
0
5737
0
$headtext .= "$header: " . $request->{'outheaders'}{$header} . "\r\n";
5738
}
5739
0
print $sock $headtext."\r\n";
5740
0
$evp->remove($sock);
5741
0
$request->{'client'} = undef;
5742
0
MHFS::Process->cmd_to_sock(\@command, $sock);
5743
}
5744
5745
sub hls_audio_formattime {
5746
0
0
my ($ttime) = @_;
5747
0
my $hours = int($ttime / 3600);
5748
0
$ttime -= ($hours * 3600);
5749
0
my $minutes = int($ttime / 60);
5750
0
$ttime -= ($minutes*60);
5751
#my $seconds = int($ttime);
5752
#$ttime -= $seconds;
5753
#say "ttime $ttime";
5754
#my $mili = int($ttime * 1000000);
5755
#say "mili $mili";
5756
#my $tstring = sprintf "%02d:%02d:%02d.%06d", $hours, $minutes, $seconds, $mili;
5757
0
my $tstring = sprintf "%02d:%02d:%f", $hours, $minutes, $ttime;
5758
0
return $tstring;
5759
}
5760
5761
sub adts_get_packet_size {
5762
0
0
my ($buf) = @_;
5763
0
my ($sync, $stuff, $rest) = unpack('nCN', $buf);
5764
0
0
if(!defined($sync)) {
5765
0
say "no pack, len " . length($buf);
5766
0
return undef;
5767
}
5768
0
0
if($sync != 0xFFF1) {
5769
0
say "bad sync";
5770
0
return undef;
5771
}
5772
5773
0
my $size = ($rest >> 13) & 0x1FFF;
5774
0
return $size;
5775
}
5776
5777
sub ebml_read {
5778
0
0
my $ebml = $_[0];
5779
0
my $buf = \$_[1];
5780
0
my $amount = $_[2];
5781
0
0
my $lastelm = ($ebml->{'elements'} > 0) ? $ebml->{'elements'}[-1] : undef;
5782
0
0
0
return undef if($lastelm && defined($lastelm->{'size'}) && ($amount > $lastelm->{'size'}));
0
5783
5784
0
my $amtread = read($ebml->{'fh'}, $$buf, $amount);
5785
0
0
if(! $amtread) {
5786
0
return $amtread;
5787
}
5788
5789
0
foreach my $elem (@{$ebml->{'elements'}}) {
0
5790
0
0
if($elem->{'size'}) {
5791
0
$elem->{'size'} -= $amtread;
5792
}
5793
}
5794
0
return $amtread;
5795
}
5796
5797
sub ebml_seek {
5798
0
0
my ($ebml, $position, $whence) = @_;
5799
0
0
($whence == SEEK_CUR) or die("unsupported seek");
5800
0
0
0
return undef if(($ebml->{'elements'} > 0) && $ebml->{'elements'}[-1]{'size'} && ($position > $ebml->{'elements'}[-1]{'size'}));
0
5801
0
0
return undef if(!seek($ebml->{'fh'}, $position, $whence));
5802
0
foreach my $elem (@{$ebml->{'elements'}}) {
0
5803
0
0
if($elem->{'size'}) {
5804
0
$elem->{'size'} -= $position;
5805
}
5806
}
5807
0
return 1;
5808
}
5809
5810
sub read_vint_from_buf {
5811
0
0
my $bufref = $_[0];
5812
0
my $savewidth = $_[1];
5813
5814
0
my $width = 1;
5815
0
my $value = unpack('C', substr($$bufref, 0, 1, ''));
5816
0
for(;;$width++) {
5817
0
0
last if(($value << ($width-1)) & 0x80);
5818
0
0
$width < 9 or return undef;
5819
}
5820
5821
0
0
length($$bufref) >= ($width-1) or return undef;
5822
5823
0
for(my $wcopy = $width; $wcopy > 1; $wcopy--) {
5824
0
$value <<= 8;
5825
0
$value |= unpack('C', substr($$bufref, 0, 1, ''));
5826
}
5827
5828
0
$$savewidth = $width;
5829
0
return $value;
5830
}
5831
5832
sub read_and_parse_vint_from_buf {
5833
0
0
my $bufref = $_[0];
5834
0
my $savewidth = $_[1];
5835
5836
0
my $width;
5837
0
my $value = read_vint_from_buf($bufref, \$width);
5838
0
0
defined($value) or return undef;
5839
5840
0
my $andval = 0xFF >> $width;
5841
0
for(my $wcopy = $width; $wcopy > 1; $wcopy--) {
5842
0
$andval <<= 8;
5843
0
$andval |= 0xFF;
5844
}
5845
0
$value &= $andval;
5846
0
0
if(defined $savewidth) {
5847
0
$$savewidth = $width;
5848
}
5849
0
return $value;
5850
}
5851
5852
sub read_vint {
5853
0
0
my ($ebml, $val, $savewidth) = @_;
5854
0
my $value;
5855
0
0
ebml_read($ebml, $value, 1) or return 0;
5856
0
my $width = 1;
5857
0
$value = unpack('C', $value);
5858
0
for(;;$width++) {
5859
0
0
last if(($value << ($width-1)) & 0x80);
5860
0
0
$width < 9 or return 0;
5861
}
5862
0
$$savewidth = $width;
5863
0
my $byte;
5864
0
for(; $width > 1; $width--) {
5865
0
$value <<= 8;
5866
0
0
ebml_read($ebml, $byte, 1) or return 0;
5867
0
$value |= unpack('C', $byte);
5868
}
5869
0
$$val = $value;
5870
0
return 1;
5871
}
5872
5873
sub read_and_parse_vint {
5874
0
0
my ($ebml, $val) = @_;
5875
0
my $value;
5876
my $width;
5877
0
0
read_vint($ebml, \$value, \$width) or return 0;
5878
0
my $andval = 0xFF >> $width;
5879
0
for(;$width > 1; $width--) {
5880
0
$andval <<= 8;
5881
0
$andval |= 0xFF;
5882
}
5883
0
$value &= $andval;
5884
0
$$val = $value;
5885
0
return 1;
5886
}
5887
5888
sub ebml_open {
5889
0
0
my ($filename) = @_;
5890
0
0
open(my $fh, "<", $filename) or return 0;
5891
0
my $magic;
5892
0
0
read($fh, $magic, 4) or return 0;
5893
0
0
$magic eq "\x1A\x45\xDF\xA3" or return 0;
5894
0
my $ebmlheadsize;
5895
0
my $ebml = {'fh' => $fh, 'elements' => []};
5896
0
0
read_and_parse_vint($ebml, \$ebmlheadsize) or return 0;
5897
0
0
seek($fh, $ebmlheadsize, SEEK_CUR) or return 0;
5898
0
return $ebml;
5899
}
5900
5901
sub ebml_read_element {
5902
0
0
my ($ebml) = @_;
5903
0
my $id;
5904
0
0
read_vint($ebml, \$id) or return undef;
5905
0
my $size;
5906
0
0
read_and_parse_vint($ebml, \$size) or return undef;
5907
0
my $elm = {'id' => $id, 'size' => $size};
5908
0
push @{$ebml->{'elements'}}, $elm;
0
5909
0
return $elm;
5910
}
5911
5912
sub ebml_skip {
5913
0
0
my ($ebml) = @_;
5914
0
my $elm = $ebml->{'elements'}[-1];
5915
0
0
ebml_seek($ebml, $elm->{'size'}, SEEK_CUR) or return 0;
5916
0
pop @{$ebml->{'elements'}};
0
5917
0
return 1;
5918
}
5919
5920
sub ebml_find_id {
5921
0
0
my ($ebml, $id) = @_;
5922
0
for(;;) {
5923
0
my $elm = ebml_read_element($ebml);
5924
0
0
$elm or return undef;
5925
0
0
if($elm->{'id'} == $id) {
5926
0
return $elm;
5927
}
5928
#say "id " . $elm->{'id'};
5929
0
0
ebml_skip($ebml) or return undef;
5930
}
5931
}
5932
5933
sub ebml_make_elms {
5934
0
0
my @elms = @_;
5935
0
my @bufstack = ('');
5936
0
while(@elms) {
5937
0
my $elm = $elms[0];
5938
0
0
if(! $elm) {
0
5939
0
shift @elms;
5940
0
$elm = $elms[0];
5941
0
$elm->{'data'} = pop @bufstack;
5942
}
5943
elsif(! $elm->{'data'}) {
5944
0
@elms = (@{$elm->{'elms'}}, undef, @elms);
0
5945
0
push @bufstack, '';
5946
0
next;
5947
}
5948
0
shift @elms;
5949
0
my $elementid = $elm->{'id'};
5950
0
0
if(! $elementid) {
5951
0
print Dumper($elm);
5952
0
die;
5953
}
5954
0
0
$elementid < 0xFFFFFFFF or return undef;
5955
0
my $data = \$elm->{'data'};
5956
5957
0
my $size = length($$data);
5958
0
0
$size < 0xFFFFFFFFFFFFFF or return undef;
5959
# pack the id
5960
0
my $buf;
5961
0
0
if($elementid > 0xFFFFFF) {
0
0
5962
# pack BE uint32_t
5963
#$buf = pack('CCCC', ($elementid >> 24) & 0xFF, ($elementid >> 16) & 0xFF, ($elementid >> 8) & 0xFF, $elementid & 0xFF);
5964
0
$buf = pack('N', $elementid);
5965
}
5966
elsif($elementid > 0xFFFF) {
5967
# pack BE uint24_t
5968
0
$buf = pack('CCC', ($elementid >> 16) & 0xFF, ($elementid >> 8) & 0xFF, $elementid & 0xFF);
5969
}
5970
elsif($elementid > 0xFF) {
5971
# pack BE uint16_t
5972
#$buf = pack('CC', ($elementid >> 8) & 0xFF, $elementid & 0xFF);
5973
0
$buf = pack('n', $elementid);
5974
}
5975
else {
5976
# pack BE uint8_t
5977
0
$buf = pack('C', $elementid & 0xFF);
5978
}
5979
5980
# pack the size
5981
0
0
if($elm->{'infsize'}) {
5982
0
$buf .= pack('C', 0xFF);
5983
}
5984
else {
5985
# determine the VINT width and marker value, and the size needed for the vint
5986
0
my $sizeflag = 0x80;
5987
0
my $bitwidth = 0x8;
5988
0
while($size >= $sizeflag) {
5989
0
$bitwidth += 0x8;
5990
0
$sizeflag <<= 0x7;
5991
}
5992
5993
# Apply the VINT marker and pack the vint
5994
0
$size |= $sizeflag;
5995
0
while($bitwidth) {
5996
0
$bitwidth -= 8;
5997
0
$buf .= pack('C', ($size >> $bitwidth) & 0xFF);
5998
}
5999
}
6000
6001
# pack the data
6002
0
$buf .= $$data;
6003
0
$bufstack[-1] .= $buf;
6004
}
6005
6006
0
return \$bufstack[0];
6007
}
6008
6009
6010
use constant {
6011
1
6719
'EBMLID_EBMLHead' => 0x1A45DFA3,
6012
'EBMLID_EBMLVersion' => 0x4286,
6013
'EBMLID_EBMLReadVersion' => 0x42F7,
6014
'EBMLID_EBMLMaxIDLength' => 0x42F2,
6015
'EBMLID_EBMLMaxSizeLength' => 0x42F3,
6016
'EBMLID_EBMLDocType' => 0x4282,
6017
'EBMLID_EBMLDocTypeVer' => 0x4287,
6018
'EBMLID_EBMLDocTypeReadVer' => 0x4285,
6019
'EBMLID_Segment' => 0x18538067,
6020
'EBMLID_SegmentInfo' => 0x1549A966,
6021
'EBMLID_TimestampScale' => 0x2AD7B1,
6022
'EBMLID_Duration' => 0x4489,
6023
'EBMLID_MuxingApp' => 0x4D80,
6024
'EBMLID_WritingApp' => 0x5741,
6025
'EBMLID_Tracks' => 0x1654AE6B,
6026
'EBMLID_Track' => 0xAE,
6027
'EBMLID_TrackNumber' => 0xD7,
6028
'EBMLID_TrackUID' => 0x73C5,
6029
'EBMLID_TrackType' => 0x83,
6030
'EBMLID_DefaulDuration' => 0x23E383,
6031
'EBMLID_CodecID' => 0x86,
6032
'EBMLID_CodecPrivData', => 0x63A2,
6033
'EBMLID_AudioTrack' => 0xE1,
6034
'EBMLID_AudioChannels' => 0x9F,
6035
'EBMLID_AudioSampleRate' => 0xB5,
6036
'EBMLID_AudioBitDepth' => 0x6264,
6037
'EBMLID_Cluster' => 0x1F43B675,
6038
'EBMLID_ClusterTimestamp' => 0xE7,
6039
'EBMLID_SimpleBlock' => 0xA3,
6040
'EBMLID_BlockGroup' => 0xA0,
6041
'EBMLID_Block' => 0xA1
6042
1
1
11
};
1
3
6043
6044
sub matroska_cluster_parse_simpleblock_or_blockgroup {
6045
0
0
my ($elm) = @_;
6046
6047
0
my $data = $elm->{'data'};
6048
0
0
if($elm->{'id'} == EBMLID_BlockGroup) {
0
6049
0
say "blockgroup";
6050
0
while(1) {
6051
0
my $width;
6052
0
my $id = read_vint_from_buf(\$data, \$width);
6053
0
0
defined($id) or return undef;
6054
0
my $size = read_and_parse_vint_from_buf(\$data);
6055
0
0
defined($size) or return undef;
6056
0
say "blockgroup item: $id $size";
6057
0
0
last if($id == EBMLID_Block);
6058
0
substr($data, 0, $size, '');
6059
}
6060
0
say "IS BLOCK";
6061
}
6062
elsif($elm->{'id'} == EBMLID_SimpleBlock) {
6063
#say "IS SIMPLEBLOCK";
6064
}
6065
else {
6066
0
die "unhandled block type";
6067
}
6068
0
my $trackno = read_and_parse_vint_from_buf(\$data);
6069
0
0
0
if((!defined $trackno) || (length($data) < 3)) {
6070
0
return undef;
6071
}
6072
0
my $rawts = substr($data, 0, 2, '');
6073
0
my $rawflag = substr($data, 0, 1, '');
6074
6075
0
my $lacing = unpack('C', $rawflag) & 0x6;
6076
0
my $framecnt;
6077
my @sizes;
6078
# XIPH
6079
0
0
if($lacing == 0x2) {
0
0
6080
0
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
6081
0
my $firstframessize = 0;
6082
0
for(my $i = 0; $i < ($framecnt-1); $i++) {
6083
0
my $fsize = 0;
6084
0
while(1) {
6085
0
my $val = unpack('C', substr($data, 0, 1, ''));
6086
0
$fsize += $val;
6087
0
0
last if($val < 255);
6088
}
6089
0
push @sizes, $fsize;
6090
0
$firstframessize += $fsize;
6091
}
6092
0
push @sizes, (length($data) - $firstframessize);
6093
}
6094
# EBML
6095
elsif($lacing == 0x6) {
6096
0
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
6097
0
my $last = read_and_parse_vint_from_buf(\$data);
6098
0
push @sizes, $last;
6099
0
my $sum = $last;
6100
0
for(my $i = 0; $i < ($framecnt - 2); $i++) {
6101
0
my $width;
6102
0
my $offset = read_and_parse_vint_from_buf(\$data, \$width);
6103
# multiple by 2^bitwidth - 1 (with adjusted bitwidth)
6104
0
my $desiredbits = (8 * $width) - ($width+1);
6105
0
my $subtract = (1 << $desiredbits) - 1;
6106
0
my $result = $offset - $subtract;
6107
0
$last += $result;
6108
0
say "offset $offset width $width factor: " . sprintf("0x%X ", $subtract) . "result $result evaled $last";
6109
0
push @sizes, $last;
6110
0
$sum += $last;
6111
}
6112
0
my $lastlast = length($data) - $sum;
6113
0
say "lastlast $lastlast";
6114
0
push @sizes, $lastlast;
6115
}
6116
# fixed
6117
elsif($lacing == 0x4) {
6118
0
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
6119
0
my $framesize = length($data) / $framecnt;
6120
0
for(my $i = 0; $i < $framecnt; $i++) {
6121
0
push @sizes, $framesize;
6122
}
6123
}
6124
# no lacing
6125
else {
6126
0
push @sizes, length($data);
6127
}
6128
6129
return {
6130
0
'trackno' => $trackno,
6131
'rawts' => $rawts,
6132
'rawflag' => $rawflag,
6133
'frame_lengths' => \@sizes,
6134
'data' => $data,
6135
'ts' => unpack('s>', $rawts)
6136
};
6137
}
6138
6139
sub telmval {
6140
0
0
my ($track, $stringid) = @_;
6141
0
my $constname = "EBMLID_$stringid";
6142
0
my $id = __PACKAGE__->$constname;
6143
0
0
return $track->{$id}{'value'} // $track->{$id}{'data'};
6144
#return $track->{"$stringid"}}{'value'} // $track->{$EBMLID->{$stringid}}{'data'};
6145
}
6146
6147
sub trackno_is_audio {
6148
0
0
my ($tracks, $trackno) = @_;
6149
0
foreach my $track (@$tracks) {
6150
0
0
if(telmval($track, 'TrackNumber') == $trackno) {
6151
0
return telmval($track, 'TrackType') == 0x2;
6152
}
6153
}
6154
0
return undef;
6155
}
6156
6157
sub flac_read_METADATA_BLOCK {
6158
0
0
my $fh = $_[0];
6159
0
my $type = \$_[1];
6160
0
my $done = \$_[2];
6161
0
my $buf;
6162
0
my $headread = read($fh, $buf, 4);
6163
0
0
0
($headread && ($headread == 4)) or return undef;
6164
0
my ($blocktypelast, $sizehi, $sizemid, $sizelo) = unpack('CCCC',$buf);
6165
0
$$done = $blocktypelast & 0x80;
6166
0
$$type = $blocktypelast & 0x7F;
6167
0
my $size = ($sizehi << 16) | ($sizemid << 8) | ($sizelo);
6168
#say "islast $$done type $type size $size";
6169
0
0
$$type != 0x7F or return undef;
6170
0
my $tbuf;
6171
0
my $dataread = read($fh, $tbuf, $size);
6172
0
0
0
($dataread && ($dataread == $size)) or return undef;
6173
0
$buf .= $tbuf;
6174
0
return \$buf;
6175
}
6176
6177
sub flac_parseStreamInfo {
6178
# https://metacpan.org/source/DANIEL/Audio-FLAC-Header-2.4/Header.pm
6179
0
0
my ($buf) = @_;
6180
0
my $metaBinString = unpack('B144', $buf);
6181
6182
0
my $x32 = 0 x 32;
6183
0
my $info = {};
6184
0
$info->{'MINIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 0, 16), -32)));
6185
0
$info->{'MAXIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 16, 16), -32)));
6186
0
$info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 32, 24), -32)));
6187
0
$info->{'MAXIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 56, 24), -32)));
6188
6189
0
$info->{'SAMPLERATE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 80, 20), -32)));
6190
0
$info->{'NUMCHANNELS'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 3), -32))) + 1;
6191
0
$info->{'BITSPERSAMPLE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 103, 5), -32))) + 1;
6192
6193
# Calculate total samples in two parts
6194
0
my $highBits = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 108, 4), -32)));
6195
6196
0
$info->{'TOTALSAMPLES'} = $highBits * 2 ** 32 +
6197
unpack('N', pack('B32', substr($x32 . substr($metaBinString, 112, 32), -32)));
6198
6199
# Return the MD5 as a 32-character hexadecimal string
6200
0
$info->{'MD5CHECKSUM'} = unpack('H32',substr($buf, 18, 16));
6201
0
return $info;
6202
}
6203
6204
sub flac_read_to_audio {
6205
0
0
my ($fh) = @_;
6206
0
my $buf;
6207
0
my $magic = read($fh, $buf, 4);
6208
0
0
0
($magic && ($magic == 4)) or return undef;
6209
0
my $streaminfo;
6210
0
for(;;) {
6211
0
my $type;
6212
my $done;
6213
0
my $bref = flac_read_METADATA_BLOCK($fh, $type, $done);
6214
0
0
$bref or return undef;
6215
0
$buf .= $$bref;
6216
0
0
if($type == 0) {
6217
0
$streaminfo = flac_parseStreamInfo(substr($$bref, 4));
6218
}
6219
0
0
last if($done);
6220
}
6221
0
return {'streaminfo' => $streaminfo, 'buf' => \$buf};
6222
}
6223
6224
sub parse_uinteger_str {
6225
0
0
my ($str) = @_;
6226
0
my @values = unpack('C'x length($str), $str);
6227
0
my $value = 0;
6228
0
my $shift = 0;
6229
0
while(@values) {
6230
0
$value |= ((pop @values) << $shift);
6231
0
$shift += 8;
6232
}
6233
0
return $value;
6234
}
6235
6236
sub parse_float_str {
6237
0
0
my ($str) = @_;
6238
0
0
return 0 if(length($str) == 0);
6239
6240
0
0
return unpack('f>', $str) if(length($str) == 4);
6241
6242
0
0
return unpack('d>', $str) if(length($str) == 8);
6243
6244
0
return undef;
6245
}
6246
6247
# matroska object needs
6248
# - ebml
6249
# - tsscale
6250
# - tracks
6251
# - audio track, codec, channels, samplerate
6252
# - video track, fps
6253
# - duration
6254
6255
sub matroska_open {
6256
0
0
my ($filename) = @_;
6257
0
my $ebml = ebml_open($filename);
6258
0
0
if(! $ebml) {
6259
0
return undef;
6260
}
6261
6262
# find segment
6263
0
my $foundsegment = ebml_find_id($ebml, EBMLID_Segment);
6264
0
0
if(!$foundsegment) {
6265
0
return undef;
6266
}
6267
0
say "Found segment";
6268
0
my %segment = (id => EBMLID_Segment, 'infsize' => 1, 'elms' => []);
6269
6270
# find segment info
6271
0
my $foundsegmentinfo = ebml_find_id($ebml, EBMLID_SegmentInfo);
6272
0
0
if(!$foundsegmentinfo) {
6273
0
return undef;
6274
}
6275
0
say "Found segment info";
6276
0
my %segmentinfo = (id => EBMLID_SegmentInfo, elms => []);
6277
6278
# find TimestampScale
6279
0
my $tselm = ebml_find_id($ebml, EBMLID_TimestampScale);
6280
0
0
if(!$tselm) {
6281
0
return undef;
6282
}
6283
0
say "Found ts elm";
6284
0
my $tsbinary;
6285
0
0
if(!ebml_read($ebml, $tsbinary, $tselm->{'size'})) {
6286
0
return undef;
6287
}
6288
6289
0
Dump($tsbinary);
6290
0
my $tsval = parse_uinteger_str($tsbinary);
6291
0
0
defined($tsval) or return undef;
6292
0
say "tsval: $tsval";
6293
6294
0
0
if(!ebml_skip($ebml)) {
6295
0
return undef;
6296
}
6297
0
push @{$segmentinfo{'elms'}}, {id => EBMLID_TimestampScale, data => $tsbinary};
0
6298
6299
# find Duration
6300
0
my $durationelm = ebml_find_id($ebml, EBMLID_Duration);
6301
0
0
if(!$durationelm) {
6302
0
return undef;
6303
}
6304
0
say "Found duration elm";
6305
0
my $durbin;
6306
0
0
if(!ebml_read($ebml, $durbin, $durationelm->{'size'})) {
6307
0
return undef;
6308
}
6309
0
Dump($durbin);
6310
0
my $scaledduration = parse_float_str($durbin);
6311
6312
0
say "scaledduration $scaledduration";
6313
6314
0
my $duration = ($tsval * $scaledduration)/1000000000;
6315
0
say "duration: $duration";
6316
6317
# exit duration
6318
0
0
if(!ebml_skip($ebml)) {
6319
0
return undef;
6320
}
6321
6322
# exit segment informations
6323
0
0
if(!ebml_skip($ebml)) {
6324
0
return undef;
6325
}
6326
6327
# find tracks
6328
0
my $in_tracks = ebml_find_id($ebml, EBMLID_Tracks);
6329
0
0
if(!$in_tracks) {
6330
0
return undef;
6331
}
6332
# loop through the Tracks
6333
0
my %CodecPCMFrameLength = ( 'AAC' => 1024, 'EAC3' => 1536, 'AC3' => 1536, 'PCM' => 1);
6334
my %CodecGetSegment = ('AAC' => sub {
6335
0
0
my ($seginfo, $dataref) = @_;
6336
0
my $targetpackets = $seginfo->{'expected'} / $CodecPCMFrameLength{'AAC'};
6337
0
my $start = 0;
6338
0
my $packetsread = 0;
6339
0
while(1) {
6340
0
my $packetsize = adts_get_packet_size(substr($$dataref, $start, 7));
6341
0
0
$packetsize or return undef;
6342
0
say "packet size $packetsize";
6343
0
$start += $packetsize;
6344
0
$packetsread++;
6345
0
0
if($packetsread == $targetpackets) {
6346
0
return {'mime' => 'audio/aac', 'data' => hls_audio_get_id3($seginfo->{'stime'}).substr($$dataref, 0, $start, '')};
6347
}
6348
}
6349
0
return undef;
6350
}, 'PCM' => sub {
6351
0
0
my ($seginfo, $dataref) = @_;
6352
0
my $targetsize = 2 * $seginfo->{'channels'}* $seginfo->{'expected'};
6353
0
0
if(length($$dataref) >= $targetsize) {
6354
0
return {'mime' => 'application/octet-stream', 'data' => substr($$dataref, 0, $targetsize, '')};
6355
}
6356
0
return undef;
6357
0
});
6358
0
my @tracks;
6359
0
for(;;) {
6360
0
my $in_track = ebml_find_id($ebml, EBMLID_Track);
6361
0
0
if(! $in_track) {
6362
0
ebml_skip($ebml);
6363
0
last;
6364
}
6365
0
my %track = ('id' => EBMLID_Track);
6366
0
for(;;) {
6367
0
my $telm = ebml_read_element($ebml);
6368
0
0
if(!$telm) {
6369
0
ebml_skip($ebml);
6370
0
last;
6371
}
6372
6373
# save the element into tracks
6374
0
my %elm = ('id' => $telm->{'id'}, 'data' => '');
6375
0
ebml_read($ebml, $elm{'data'}, $telm->{'size'});
6376
0
0
if($elm{'id'} == EBMLID_TrackNumber) {
0
0
0
0
0
6377
0
say "trackno";
6378
0
$elm{'value'} = unpack('C', $elm{'data'});
6379
0
$track{$elm{'id'}} = \%elm;
6380
}
6381
elsif($elm{'id'} == EBMLID_CodecID) {
6382
0
say "codec " . $elm{'data'};
6383
0
0
if($elm{'data'} =~ /^([A-Z]+_)([A-Z0-9]+)(?:\/([A-Z0-9_\/]+))?$/) {
6384
0
$track{'CodecID_Prefix'} = $1;
6385
0
$track{'CodecID_Major'} = $2;
6386
0
0
if($3) {
6387
0
$track{'CodecID_Minor'} = $3;
6388
}
6389
0
0
$track{'PCMFrameLength'} = $CodecPCMFrameLength{$track{'CodecID_Major'}} if($track{'CodecID_Prefix'} eq 'A_');
6390
}
6391
0
$track{$elm{'id'}} = \%elm;
6392
}
6393
elsif($elm{'id'} == EBMLID_TrackType) {
6394
0
say "tracktype";
6395
0
$elm{'value'} = unpack('C', $elm{'data'});
6396
0
$track{$elm{'id'}} = \%elm;
6397
}
6398
elsif($elm{'id'} == EBMLID_TrackUID) {
6399
0
say "trackuid";
6400
0
$track{$elm{'id'}} = \%elm;
6401
}
6402
elsif($elm{'id'} == EBMLID_DefaulDuration) {
6403
0
say "defaultduration";
6404
0
$elm{'value'} = parse_uinteger_str($elm{'data'});
6405
0
$track{$elm{'id'}} = \%elm;
6406
0
$track{'fps'} = int(((1/($elm{'value'} / 1000000000)) * 1000) + 0.5)/1000;
6407
}
6408
elsif($elm{'id'} == EBMLID_AudioTrack) {
6409
0
say "audiotrack";
6410
0
my $buf = $elm{'data'};
6411
0
while(length($buf)) {
6412
# read the id, size, and data
6413
0
my $vintwidth;
6414
0
my $id = read_vint_from_buf(\$buf, \$vintwidth);
6415
0
0
if(!$id) {
6416
0
last;
6417
}
6418
0
say "elmid $id width $vintwidth";
6419
0
say sprintf("0x%X 0x%X", ord(substr($buf, 0, 1)), ord(substr($buf, 1, 1)));
6420
0
my $size = read_and_parse_vint_from_buf(\$buf);
6421
0
0
if(!$size) {
6422
0
last;
6423
}
6424
0
say "size $size";
6425
0
my $data = substr($buf, 0, $size, '');
6426
6427
# save metadata
6428
0
0
if($id == EBMLID_AudioSampleRate) {
0
6429
0
$track{$id} = parse_float_str($data);
6430
0
say "samplerate " . $track{$id};
6431
}
6432
elsif($id == EBMLID_AudioChannels) {
6433
0
$track{$id} = parse_uinteger_str($data);
6434
0
say "channels " . $track{$id};
6435
}
6436
}
6437
}
6438
6439
0
ebml_skip($ebml);
6440
}
6441
# add the fake track
6442
0
0
0
if(($track{'CodecID_Major'} eq 'EAC3') || ($track{'CodecID_Major'} eq 'AC3')) {
6443
$track{'faketrack'} = {
6444
'PCMFrameLength' => $CodecPCMFrameLength{'AAC'},
6445
&EBMLID_AudioSampleRate => $track{&EBMLID_AudioSampleRate},
6446
0
&EBMLID_AudioChannels => $track{&EBMLID_AudioChannels}
6447
};
6448
#$track{'outfmt'} = 'PCM';
6449
#$track{'outChannels'} = $track{&EBMLID_AudioChannels};
6450
0
$track{'outfmt'} = 'AAC';
6451
0
$track{'outChannels'} = 2;
6452
6453
0
$track{'outPCMFrameLength'} = $CodecPCMFrameLength{$track{'outfmt'}};
6454
0
$track{'outGetSegment'} = $CodecGetSegment{$track{'outfmt'}};
6455
6456
}
6457
0
push @tracks, \%track;
6458
}
6459
0
0
if(scalar(@tracks) == 0) {
6460
0
return undef;
6461
}
6462
6463
0
my $segmentelm = $ebml->{'elements'}[0];
6464
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' => []);
6465
0
return \%matroska;
6466
}
6467
6468
sub matroska_get_audio_track {
6469
0
0
my ($matroska) = @_;
6470
0
foreach my $track (@{$matroska->{'tracks'}}) {
0
6471
0
my $tt = $track->{&EBMLID_TrackType};
6472
0
0
0
if(defined $tt && ($tt->{'value'} == 2)) {
6473
0
return $track;
6474
}
6475
}
6476
0
return undef;
6477
}
6478
6479
sub matroska_get_video_track {
6480
0
0
my ($matroska) = @_;
6481
0
foreach my $track (@{$matroska->{'tracks'}}) {
0
6482
0
my $tt = $track->{&EBMLID_TrackType};
6483
0
0
0
if(defined $tt && ($tt->{'value'} == 1)) {
6484
0
return $track;
6485
}
6486
}
6487
0
return undef;
6488
}
6489
6490
sub matroska_read_cluster_metadata {
6491
0
0
my ($matroska) = @_;
6492
0
my $ebml = $matroska->{'ebml'};
6493
6494
# find a cluster
6495
0
my $custer = ebml_find_id($ebml, EBMLID_Cluster);
6496
0
0
return undef if(! $custer);
6497
0
my %cluster = ( 'fileoffset' => tell($ebml->{'fh'}), 'size' => $custer->{'size'}, 'Segment_sizeleft' => $ebml->{'elements'}[0]{'size'});
6498
6499
# find the cluster timestamp
6500
0
for(;;) {
6501
0
my $belm = ebml_read_element($ebml);
6502
0
0
if(!$belm) {
6503
0
ebml_skip($ebml);
6504
0
last;
6505
}
6506
0
my %elm = ('id' => $belm->{'id'}, 'data' => '');
6507
#say "elm size " . $belm->{'size'};
6508
0
ebml_read($ebml, $elm{'data'}, $belm->{'size'});
6509
0
0
if($elm{'id'} == EBMLID_ClusterTimestamp) {
6510
0
$cluster{'rawts'} = parse_uinteger_str($elm{'data'});
6511
0
$cluster{'ts'} = $cluster{'rawts'} * $matroska->{'tsscale'};
6512
# exit ClusterTimestamp
6513
0
ebml_skip($ebml);
6514
# exit cluster
6515
0
ebml_skip($ebml);
6516
0
return \%cluster;
6517
}
6518
6519
0
ebml_skip($ebml);
6520
}
6521
0
return undef;
6522
}
6523
6524
sub ebml_set_cluster {
6525
0
0
my ($ebml, $cluster) = @_;
6526
0
seek($ebml->{'fh'}, $cluster->{'fileoffset'}, SEEK_SET);
6527
$ebml->{'elements'} = [
6528
{
6529
'id' => EBMLID_Segment,
6530
'size' => $cluster->{'Segment_sizeleft'}
6531
},
6532
{
6533
'id' => EBMLID_Cluster,
6534
0
'size' => $cluster->{'size'}
6535
}
6536
];
6537
}
6538
6539
sub matroska_get_track_block {
6540
0
0
my ($matroska, $tid) = @_;
6541
0
my $ebml = $matroska->{'ebml'};
6542
0
for(;;) {
6543
0
my $belm = ebml_read_element($ebml);
6544
0
0
if(!$belm) {
6545
0
ebml_skip($ebml); # leave cluster
6546
0
my $cluster = matroska_read_cluster_metadata($matroska);
6547
0
0
if($cluster) {
6548
0
say "advancing cluster";
6549
0
$matroska->{'dc'} = $cluster;
6550
0
ebml_set_cluster($ebml, $matroska->{'dc'});
6551
0
next;
6552
}
6553
0
last;
6554
}
6555
0
my %elm = ('id' => $belm->{'id'}, 'data' => '');
6556
#say "elm size " . $belm->{'size'};
6557
6558
0
ebml_read($ebml, $elm{'data'}, $belm->{'size'});
6559
0
0
0
if(($elm{'id'} == EBMLID_SimpleBlock) || ($elm{'id'} == EBMLID_BlockGroup)) {
6560
0
my $block = matroska_cluster_parse_simpleblock_or_blockgroup(\%elm);
6561
0
0
0
if($block && ($block->{'trackno'} == $tid)) {
6562
0
ebml_skip($ebml);
6563
0
return $block;
6564
}
6565
}
6566
0
ebml_skip($ebml);
6567
}
6568
0
return undef;
6569
}
6570
6571
sub matroska_ts_to_sample {
6572
0
0
my ($matroska, $samplerate, $ts) = @_;
6573
0
my $curframe = int(($ts * $samplerate / 1000000000)+ 0.5);
6574
0
return $curframe;
6575
}
6576
6577
sub matroska_get_gop {
6578
0
0
my ($matroska, $track, $timeinseconds) = @_;
6579
0
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
6580
6581
0
my $prevcluster;
6582
my $desiredcluster;
6583
0
while(1) {
6584
0
my $cluster = matroska_read_cluster_metadata($matroska);
6585
0
0
last if(!$cluster);
6586
6587
0
my $ctime = $cluster->{'ts'} / 1000000000;
6588
6589
# this cluster could have our GOP, save it's info
6590
0
0
if($ctime <= $timeinseconds) {
6591
0
$prevcluster = $desiredcluster;
6592
0
$desiredcluster = $cluster;
6593
0
0
if($prevcluster) {
6594
0
$prevcluster->{'prevcluster'} = undef;
6595
0
$desiredcluster->{'prevcluster'} = $prevcluster;
6596
}
6597
}
6598
6599
0
0
if($ctime >= $timeinseconds) {
6600
0
last;
6601
}
6602
}
6603
0
say "before dc check";
6604
0
0
return undef if(! $desiredcluster);
6605
6606
0
say "cur rawts " . $desiredcluster->{'rawts'};
6607
0
0
say "last rawts " . $desiredcluster->{'prevcluster'}{'rawts'} if($desiredcluster->{'prevcluster'});
6608
6609
# restore to the the cluster that probably has the GOP
6610
0
my $ebml = $matroska->{'ebml'};
6611
0
ebml_set_cluster($ebml, $desiredcluster);
6612
0
$matroska->{'dc'} = $desiredcluster;
6613
6614
# find a valid track block that includes pcmFrameIndex;
6615
0
my $block;
6616
my $blocktime;
6617
0
while(1) {
6618
0
$block = matroska_get_track_block($matroska, $tid);
6619
0
0
if($block) {
6620
0
$blocktime = matroska_calc_block_fullts($matroska, $block);
6621
0
0
if($blocktime > $timeinseconds) {
6622
0
$block = undef;
6623
}
6624
0
0
if(! $matroska->{'dc'}{'firstblk'}) {
6625
0
$matroska->{'dc'}{'firstblk'} = $blocktime;
6626
}
6627
}
6628
0
0
if(! $block) {
6629
0
0
if(! $prevcluster) {
6630
0
return undef;
6631
}
6632
0
say "revert cluster";
6633
0
$matroska->{'dc'} = $prevcluster;
6634
0
ebml_set_cluster($ebml, $matroska->{'dc'});
6635
0
next;
6636
}
6637
6638
0
$prevcluster = undef;
6639
6640
0
my $blockduration = ((1/24) * scalar(@{$block->{'frame_lengths'}}));
0
6641
0
0
if($timeinseconds < ($blocktime + $blockduration)) {
6642
0
say 'got GOP at ' . $matroska->{'dc'}{'firstblk'};
6643
0
return {'goptime' => $matroska->{'dc'}{'firstblk'}};
6644
0
last;
6645
}
6646
}
6647
6648
}
6649
6650
sub matroska_seek_track {
6651
0
0
my ($matroska, $track, $pcmFrameIndex) = @_;
6652
0
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
6653
0
$matroska->{'curframe'} = 0;
6654
0
$matroska->{'curpaks'} = [];
6655
0
my $samplerate = $track->{&EBMLID_AudioSampleRate};
6656
0
my $pcmFrameLen = $track->{'PCMFrameLength'};
6657
0
0
if(!$pcmFrameLen) {
6658
0
warn("Unknown codec");
6659
0
return undef;
6660
}
6661
0
my $prevcluster;
6662
my $desiredcluster;
6663
0
while(1) {
6664
0
my $cluster = matroska_read_cluster_metadata($matroska);
6665
0
0
last if(!$cluster);
6666
0
my $curframe = matroska_ts_to_sample($matroska, $samplerate, $cluster->{'ts'});
6667
#$curframe = int(($curframe/$pcmFrameLen)+0.5)*$pcmFrameLen; # requires revert cluster
6668
0
$curframe = ceil_div($curframe, $pcmFrameLen) * $pcmFrameLen;
6669
6670
# this cluster could contain our frame, save it's info
6671
0
0
if($curframe <= $pcmFrameIndex) {
6672
0
$prevcluster = $desiredcluster;
6673
0
$desiredcluster = $cluster;
6674
0
$desiredcluster->{'frameIndex'} = $curframe;
6675
0
0
if($prevcluster) {
6676
0
$prevcluster->{'prevcluster'} = undef;
6677
0
$desiredcluster->{'prevcluster'} = $prevcluster;
6678
}
6679
}
6680
# this cluster is at or past the frame, breakout
6681
0
0
if($curframe >= $pcmFrameIndex){
6682
0
last;
6683
}
6684
}
6685
0
say "before dc check";
6686
0
0
return undef if(! $desiredcluster);
6687
6688
0
say "cur rawts " . $desiredcluster->{'rawts'};
6689
0
0
say "last rawts " . $desiredcluster->{'prevcluster'}{'rawts'} if($desiredcluster->{'prevcluster'});
6690
6691
# restore to the the cluster that probably has our audio
6692
0
my $ebml = $matroska->{'ebml'};
6693
0
ebml_set_cluster($ebml, $desiredcluster);
6694
0
$matroska->{'dc'} = $desiredcluster;
6695
6696
# find a valid track block that includes pcmFrameIndex;
6697
0
my $block;
6698
my $blockframe;
6699
0
while(1) {
6700
0
$block = matroska_get_track_block($matroska, $tid);
6701
0
0
if($block) {
6702
0
$blockframe = matroska_block_calc_frame($matroska, $block, $samplerate, $pcmFrameLen);
6703
0
0
if($blockframe > $pcmFrameIndex) {
6704
0
$block = undef;
6705
}
6706
}
6707
0
0
if(! $block) {
6708
0
0
if(! $prevcluster) {
6709
0
return undef;
6710
}
6711
0
say "revert cluster";
6712
0
$matroska->{'dc'} = $prevcluster;
6713
0
ebml_set_cluster($ebml, $matroska->{'dc'});
6714
0
next;
6715
}
6716
6717
0
$prevcluster = undef;
6718
6719
0
my $pcmSampleCount = ($pcmFrameLen * scalar(@{$block->{'frame_lengths'}}));
0
6720
0
0
if($pcmFrameIndex < ($blockframe + $pcmSampleCount)) {
6721
0
0
if((($pcmFrameIndex - $blockframe) % $pcmFrameLen) != 0) {
6722
0
say "Frame index does not align with block!";
6723
0
return undef;
6724
}
6725
0
last;
6726
}
6727
}
6728
6729
# add the data to packs
6730
0
my $offset = 0;
6731
0
while($blockframe < $pcmFrameIndex) {
6732
0
my $len = shift @{$block->{'frame_lengths'}};
0
6733
0
$offset += $len;
6734
0
$blockframe += $pcmFrameLen;
6735
}
6736
0
$matroska->{'curframe'} = $pcmFrameIndex;
6737
0
foreach my $len (@{$block->{'frame_lengths'}}) {
0
6738
0
push @{$matroska->{'curpaks'}}, substr($block->{'data'}, $offset, $len);
0
6739
0
$offset += $len;
6740
}
6741
0
return 1;
6742
}
6743
6744
sub matroska_calc_block_fullts {
6745
0
0
my ($matroska, $block) = @_;
6746
0
say 'clusterts ' . ($matroska->{'dc'}->{'ts'}/1000000000);
6747
0
say 'blockts ' . $block->{'ts'};
6748
0
my $time = ($matroska->{'dc'}->{'rawts'} + $block->{'ts'}) * $matroska->{'tsscale'};
6749
0
return ($time/1000000000);
6750
}
6751
6752
sub matroska_block_calc_frame {
6753
0
0
my ($matroska, $block, $samplerate, $pcmFrameLen) = @_;
6754
0
say 'clusterts ' . ($matroska->{'dc'}->{'ts'}/1000000000);
6755
0
say 'blockts ' . $block->{'ts'};
6756
0
my $time = ($matroska->{'dc'}->{'rawts'} + $block->{'ts'}) * $matroska->{'tsscale'};
6757
0
say 'blocktime ' . ($time/1000000000);
6758
0
my $calcframe = matroska_ts_to_sample($matroska, $samplerate, $time);
6759
0
return round($calcframe/$pcmFrameLen)*$pcmFrameLen;
6760
}
6761
6762
sub matroska_read_track {
6763
0
0
my ($matroska, $track, $pcmFrameIndex, $numsamples, $formatpacket) = @_;
6764
0
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
6765
0
my $samplerate = $track->{&EBMLID_AudioSampleRate};
6766
0
my $pcmFrameLen = $track->{'PCMFrameLength'};
6767
0
0
if(!$pcmFrameLen) {
6768
0
warn("Unknown codec");
6769
0
return undef;
6770
}
6771
6772
# find the cluster that might have the start of our audio
6773
0
0
if($matroska->{'curframe'} != $pcmFrameIndex) {
6774
0
say "do seek";
6775
0
0
if(!matroska_seek_track($matroska, $track, $pcmFrameIndex)) {
6776
0
return undef;
6777
}
6778
}
6779
6780
0
my $outdata;
6781
0
my $destframe = $matroska->{'curframe'} + $numsamples;
6782
6783
0
while(1) {
6784
# add read audio
6785
0
while(@{$matroska->{'curpaks'}}) {
0
6786
0
my $pak = shift @{$matroska->{'curpaks'}};
0
6787
0
$outdata .= $formatpacket->($pak, $samplerate);
6788
0
$matroska->{'curframe'} += $pcmFrameLen;
6789
0
0
if($matroska->{'curframe'} == $destframe) {
6790
0
say "done, read enough";
6791
0
return $outdata;
6792
}
6793
}
6794
6795
# load a block
6796
0
my $block = matroska_get_track_block($matroska, $tid);
6797
0
0
if(! $block) {
6798
0
0
0
if(($matroska->{'ebml'}{'elements'}[0]{'id'} == EBMLID_Segment) && ($matroska->{'ebml'}{'elements'}[0]{'size'} == 0)) {
6799
0
say "done, EOF";
6800
}
6801
else {
6802
0
say "done, Error";
6803
}
6804
0
return $outdata;
6805
}
6806
6807
# add the data to paks
6808
0
my $offset = 0;
6809
0
foreach my $len (@{$block->{'frame_lengths'}}) {
0
6810
0
push @{$matroska->{'curpaks'}}, substr($block->{'data'}, $offset, $len);
0
6811
0
$offset += $len;
6812
}
6813
}
6814
}
6815
6816
sub video_on_streams {
6817
0
0
my ($video, $request, $continue) = @_;
6818
0
$video->{'audio'} = [];
6819
0
$video->{'video'} = [];
6820
0
$video->{'subtitle'} = [];
6821
0
my $input_file = $video->{'src_file'}{'filepath'};
6822
0
my @command = ('ffmpeg', '-i', $input_file);
6823
0
my $evp = $request->{'client'}{'server'}{'evp'};
6824
MHFS::Process->new_output_process($evp, \@command, sub {
6825
0
0
my ($output, $error) = @_;
6826
0
my @lines = split(/\n/, $error);
6827
0
my $current_stream;
6828
my $current_element;
6829
0
foreach my $eline (@lines) {
6830
0
0
if($eline =~ /^\s*Stream\s#0:(\d+)(?:\((.+)\)){0,1}:\s(.+):\s(.+)(.*)$/) {
0
0
6831
0
my $type = $3;
6832
0
$current_stream = $1;
6833
0
$current_element = { 'sindex' => $current_stream, 'lang' => $2, 'fmt' => $4, 'additional' => $5, 'metadata' => '' };
6834
0
0
$current_element->{'is_default'} = 1 if($current_element->{'fmt'} =~ /\(default\)$/i);
6835
0
0
$current_element->{'is_forced'} = 1 if($current_element->{'fmt'} =~ /FORCED/i);
6836
0
0
if($type =~ /audio/i) {
0
0
6837
0
push @{$video->{'audio'}} , $current_element;
0
6838
}
6839
elsif($type =~ /video/i) {
6840
0
push @{$video->{'video'}} , $current_element;
0
6841
}
6842
elsif($type =~ /subtitle/i) {
6843
0
push @{$video->{'subtitle'}} , $current_element;
0
6844
}
6845
0
say $eline;
6846
}
6847
elsif($eline =~ /^\s+Duration:\s+(\d\d):(\d\d):(\d\d)\.(\d\d)/) {
6848
#TODO add support for over day long video
6849
0
0
$video->{'duration'} //= "PT$1H$2M$3.$4S";
6850
0
write_file($video->{'out_location'} . '/duration', $video->{'duration'});
6851
}
6852
elsif(defined $current_stream) {
6853
0
0
if($eline !~ /^\s\s+/) {
6854
0
$current_stream = undef;
6855
0
$current_element = undef;
6856
0
next;
6857
}
6858
0
$current_element->{'metadata'} .= $eline;
6859
0
0
if($eline =~ /\s+title\s*:\s*(.+)$/) {
6860
0
$current_element->{'title'} = $1;
6861
}
6862
}
6863
}
6864
0
print Dumper($video);
6865
0
$continue->();
6866
0
});
6867
}
6868
6869
1;
6870
}
6871
6872
package MHFS::Plugin::VideoLibrary {
6873
1
1
13
use strict; use warnings;
1
1
4
1
38
1
7
1
2
1
38
6874
1
1
6
use feature 'say';
1
3
1
115
6875
1
1
8
use Encode qw(decode);
1
2
1
84
6876
1
1
8
use URI::Escape qw (uri_escape);
1
2
1
1026
6877
MHFS::Util->import(qw(output_dir_versatile escape_html uri_escape_path));
6878
6879
sub player_video {
6880
0
0
my ($request) = @_;
6881
0
my $qs = $request->{'qs'};
6882
0
my $server = $request->{'client'}{'server'};
6883
0
my $packagename = __PACKAGE__;
6884
0
my $settings = $server->{'settings'};
6885
0
my $self = $request->{'client'}{'server'}{'loaded_plugins'}{$packagename};
6886
6887
0
my $buf = "";
6888
0
$buf .= "";
6889
0
$buf .= '';
6894
0
$buf .= "";
6895
0
$buf .= "";
6896
6897
0
0
$qs->{'action'} //= 'library';
6898
6899
# action=library
6900
0
$buf .= '';
6901
0
0
$qs->{'library'} //= 'all';
6902
0
$qs->{'library'} = lc($qs->{'library'});
6903
0
my @libraries = ('movies', 'tv', 'other');
6904
0
0
if($qs->{'library'} ne 'all') {
6905
0
@libraries = ($qs->{'library'});
6906
}
6907
0
my %libraryprint = ( 'movies' => 'Movies', 'tv' => 'TV', 'other' => 'Other');
6908
0
print "plugin $_\n" foreach keys %{$server->{'loaded_plugins'}};
0
6909
0
my $fmt = $server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}->video_get_format($qs->{'fmt'});
6910
0
foreach my $library (@libraries) {
6911
0
0
exists $settings->{'MEDIASOURCES'}{$library} or next;
6912
0
my $lib = $settings->{'MEDIASOURCES'}{$library};
6913
0
my $libhtmlcontent;
6914
0
foreach my $sid (@$lib) {
6915
0
my $sublib = $settings->{'SOURCES'}{$sid};
6916
0
0
next if(! -d $sublib->{'folder'});
6917
0
$libhtmlcontent .= ${video_library_html($sublib->{'folder'}, $library, $sid, {'fmt' => $fmt})};
0
6918
}
6919
0
0
next if(! $libhtmlcontent);
6920
0
$buf .= "" . $libraryprint{$library} . "
6921
0
$buf .= $libhtmlcontent.'';
6922
}
6923
0
$buf .= '';
6924
6925
# add the video player
6926
0
$temp = $server->GetResource($server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}{'VIDEOFORMATS'}{$fmt}->{'player_html'});
6927
0
$buf .= $$temp;
6928
0
$buf .= '';
6932
0
$buf .= "";
6933
0
$buf .= "";
6934
0
$request->SendHTML($buf);
6935
}
6936
6937
sub video_library_html {
6938
0
0
my ($dir, $lib, $sid, $opt) = @_;
6939
0
my $fmt = $opt->{'fmt'};
6940
6941
0
my $urlconstant = 'lib='.$lib.'&sid='.$sid;
6942
0
my $playlisturl = "playlist/video/$sid/";
6943
6944
0
my $buf;
6945
output_dir_versatile($dir, {
6946
'root' => $dir,
6947
'min_file_size' => 100000,
6948
'on_dir_start' => sub {
6949
0
0
my ($realpath, $unsafe_relpath) = @_;
6950
0
my $relpath = uri_escape($unsafe_relpath);
6951
0
my $disppath = escape_html(decode('UTF-8', $unsafe_relpath));
6952
0
$buf .= '';
6953
0
$buf .= '' . "$$disppath ";
6954
0
$buf .= '' . "$$disppath ";
6955
0
$buf .= ' M3U ';
6956
0
$buf .= '
6957
},
6958
'on_dir_end' => sub {
6959
0
0
$buf .= '';
6960
},
6961
'on_file' => sub {
6962
0
0
my ($realpath, $unsafe_relpath, $unsafe_name) = @_;
6963
0
my $relpath = uri_escape($unsafe_relpath);
6964
0
my $filename = escape_html(decode('UTF-8', $unsafe_name));
6965
0
$buf .= '' . $$filename . ' DL M3U
6966
}
6967
0
});
6968
0
return \$buf;
6969
}
6970
6971
sub new {
6972
0
0
my ($class, $settings) = @_;
6973
0
my $self = {};
6974
0
bless $self, $class;
6975
6976
$self->{'routes'} = [
6977
[
6978
'/video', \&player_video
6979
],
6980
[
6981
'/video/', sub {
6982
0
0
my ($request) = @_;
6983
0
$request->SendRedirect(301, '../video');
6984
}
6985
0
],
6986
];
6987
0
return $self;
6988
}
6989
6990
1;
6991
}
6992
6993
package App::MHFS; #Media Http File Server
6994
1
1
8
use version; our $VERSION = version->declare("v0.5.0");
1
2
1
12
6995
1
1
112
use strict; use warnings;
1
1
2
1
32
1
6
1
2
1
27
6996
1
1
4
use feature 'say';
1
2
1
70
6997
1
1
907
use Getopt::Long qw(GetOptions);
1
10604
1
5
6998
Getopt::Long::Configure qw(gnu_getopt);
6999
7000
our $USAGE = "Usage: $0 ".<<'END_USAGE';
7001
[-h|--help] [-v|--version] [--flush] [--cfgdir ] [--appdir ]
7002
[--fallback_data_root ]
7003
Media Http File Server - Stream your own music and video library via your
7004
browser and standard media players.
7005
7006
All options are optional, provided to override settings.pl and defaults
7007
--flush turn on autoflush for STDOUT and STDERR
7008
--cfgdir location of configuration directory, will be created if
7009
it does not exist
7010
--appdir location of application static files
7011
--fallback_data_root location to fallback to if setting isn't found instead of
7012
$HOME or $APPDIR\mhfs
7013
-h|--help print this message
7014
-v|--version print version
7015
END_USAGE
7016
7017
sub run {
7018
0
0
0
binmode(STDOUT, ":utf8");
7019
0
binmode(STDERR, ":utf8");
7020
7021
# parse command line args into launchsettings
7022
0
my %launchsettings;
7023
0
my ($flush, $cfgdir, $fallback_data_root, $appdir, $help, $versionflag);
7024
0
0
if(!GetOptions(
7025
'flush' => \$flush,
7026
'cfgdir=s' => \$cfgdir,
7027
'fallback_data_root=s' => \$fallback_data_root,
7028
'appdir=s' => \$appdir,
7029
'--help|h' =>\$help,
7030
'--version|v' => \$versionflag,
7031
)) {
7032
0
print STDERR "$0: Invalid param\n";
7033
0
print STDERR $USAGE;
7034
0
exit(1);
7035
}
7036
7037
0
0
if($help) {
0
7038
0
print $USAGE;
7039
0
exit 0;
7040
}
7041
elsif($versionflag) {
7042
0
print __PACKAGE__." $VERSION";
7043
0
exit 0;
7044
}
7045
0
say __PACKAGE__ .": parsed command line args";
7046
7047
0
0
$launchsettings{flush} = $flush if($flush);
7048
0
0
$launchsettings{CFGDIR} = $cfgdir if($cfgdir);
7049
0
0
$launchsettings{FALLBACK_DATA_ROOT} = $fallback_data_root if($fallback_data_root);
7050
0
0
$launchsettings{APPDIR} = $appdir if($appdir);
7051
7052
# start the server (blocks)
7053
0
say __PACKAGE__.": starting MHFS::HTTP::Server";
7054
0
my $server = MHFS::HTTP::Server->new(\%launchsettings,
7055
['MHFS::Plugin::MusicLibrary',
7056
'MHFS::Plugin::GetVideo',
7057
'MHFS::Plugin::VideoLibrary',
7058
'MHFS::Plugin::Youtube',
7059
'MHFS::Plugin::BitTorrent::Tracker',
7060
'MHFS::Plugin::OpenDirectory',
7061
'MHFS::Plugin::Playlist',
7062
'MHFS::Plugin::Kodi',
7063
'MHFS::Plugin::BitTorrent::Client::Interface'],
7064
);
7065
}
7066
7067
1;
7068
7069
__END__