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