File Coverage

blib/lib/MHFS/HTTP/Server.pm
Criterion Covered Total %
statement 56 154 36.3
branch 0 32 0.0
condition 0 9 0.0
subroutine 19 24 79.1
pod 0 3 0.0
total 75 222 33.7


line stmt bran cond sub pod time code
1             package MHFS::HTTP::Server v0.7.0;
2 1     1   20 use 5.014;
  1         4  
3 1     1   5 use strict; use warnings;
  1     1   6  
  1         30  
  1         8  
  1         1  
  1         66  
4 1     1   6 use feature 'say';
  1         2  
  1         165  
5 1     1   716 use IO::Socket::INET;
  1         31745  
  1         10  
6 1     1   668 use Socket qw(IPPROTO_TCP TCP_KEEPALIVE TCP_NODELAY);
  1         2  
  1         297  
7 1     1   796 use IO::Poll qw(POLLIN POLLOUT POLLHUP);
  1         1195  
  1         114  
8 1     1   9 use Scalar::Util qw(weaken);
  1         3  
  1         67  
9 1     1   702 use Feature::Compat::Try;
  1         523  
  1         9  
10 1     1   135 use File::Path qw(make_path);
  1         2  
  1         80  
11 1     1   749 use Data::Dumper;
  1         11916  
  1         102  
12 1     1   9 use Carp ();
  1         2  
  1         25  
13 1     1   6 use Config;
  1         2  
  1         47  
14 1     1   670 use MHFS::EventLoop::Poll;
  1         4  
  1         75  
15 1     1   564 use MHFS::FS;
  1         4  
  1         46  
16 1     1   671 use MHFS::HTTP::Server::Client;
  1         6  
  1         57  
17 1     1   794 use MHFS::Settings;
  1         4  
  1         63  
18 1     1   8 use MHFS::Util qw(parse_ipv4 read_text_file);
  1         3  
  1         660  
19              
20             sub new {
21 0     0 0   my ($class, $launchsettings, $plugins, $routes) = @_;
22              
23             local $SIG{PIPE} = sub {
24 0     0     print STDERR "SIGPIPE @_\n";
25 0           };
26 0 0         local $SIG{ __DIE__ } = \&Carp::confess if ($launchsettings->{debug});
27              
28 0           binmode(STDOUT, ":utf8");
29 0           binmode(STDERR, ":utf8");
30              
31             # load settings
32 0           say __PACKAGE__.": loading settings";
33 0           my $settings = MHFS::Settings::load($launchsettings);
34 0 0 0       if((exists $settings->{'flush'}) && ($settings->{'flush'})) {
35 0           say __PACKAGE__.": setting autoflush on STDOUT and STDERR";
36 0           STDOUT->autoflush(1);
37 0           STDERR->autoflush(1);
38             }
39              
40             # make the temp dirs
41 0           make_path($settings->{'VIDEO_TMPDIR'}, $settings->{'MUSIC_TMPDIR'}, $settings->{'RUNTIME_DIR'}, $settings->{'GENERIC_TMPDIR'});
42 0           make_path($settings->{'SECRET_TMPDIR'}, {chmod => 0600});
43 0           make_path($settings->{'DATADIR'}, $settings->{'MHFS_TRACKER_TORRENT_DIR'});
44              
45 0           my $sock = IO::Socket::INET->new(Listen => 10000, LocalAddr => $settings->{'HOST'}, LocalPort => $settings->{'PORT'}, Proto => 'tcp', Reuse => 1, Blocking => 0);
46 0 0         if(! $sock) {
47 0           say "server: Cannot create self socket";
48 0           return undef;
49             }
50              
51 0 0         if(! $sock->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1)) {
52 0           say "server: cannot setsockopt";
53 0           return undef;
54             }
55 0           my $TCP_KEEPIDLE = 4;
56 0           my $TCP_KEEPINTVL = 5;
57 0           my $TCP_KEEPCNT = 6;
58 0           my $TCP_USER_TIMEOUT = 18;
59             #$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPIDLE, 1) or die;
60             #$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPINTVL, 1) or die;
61             #$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPCNT, 10) or die;
62             #$SERVER->setsockopt(IPPROTO_TCP, $TCP_USER_TIMEOUT, 10000) or die; #doesn't work?
63             #$SERVER->setsockopt(SOL_SOCKET, SO_LINGER, pack("II",1,0)) or die; #to stop last ack
64              
65             # leaving Nagle's algorithm enabled for now as sometimes headers are sent without data
66             #$sock->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1) or die("Failed to set TCP_NODELAY");
67              
68             # linux specific settings. Check in BEGIN?
69 0 0         if(index($Config{osname}, 'linux') != -1) {
70 1     1   9 use Socket qw(TCP_QUICKACK);
  1         3  
  1         1754  
71 0 0         $sock->setsockopt(IPPROTO_TCP, TCP_QUICKACK, 1) or die("Failed to set TCP_QUICKACK");
72             }
73 0           my $evp = MHFS::EventLoop::Poll->new;
74 0     0     my %self = ( 'settings' => $settings, 'routes' => $routes, 'route_default' => sub { $_[0]->SendDirectory($settings->{'DOCUMENTROOT'}); }, 'plugins' => $plugins, 'sock' => $sock, 'evp' => $evp, 'uploaders' => [], 'sesh' =>
  0            
75             { 'newindex' => 0, 'sessions' => {}}, 'resources' => {}, 'loaded_plugins' => {});
76 0           bless \%self, $class;
77              
78 0           $evp->set($sock, \%self, POLLIN);
79              
80 0           my $fs = MHFS::FS->new($settings->{'SOURCES'});
81 0 0         if(! $fs) {
82 0           say "failed to open MHFS::FS";
83 0           return undef;
84             }
85 0           $self{'fs'} = $fs;
86              
87             # load the plugins
88 0           foreach my $pluginname (@{$plugins}) {
  0            
89 0 0         eval "use $pluginname; 1;" or do {
90 0           say __PACKAGE__.": module $pluginname not found!";
91 0           next;
92             };
93 0 0 0       next if(defined $settings->{$pluginname}{'enabled'} && (!$settings->{$pluginname}{'enabled'}));
94 0           my $plugin = $pluginname->new($settings, \%self);
95 0 0         next if(! $plugin);
96              
97 0           foreach my $timer (@{$plugin->{'timers'}}) {
  0            
98 0           say __PACKAGE__.': adding '.ref($plugin).' timer';
99 0           $self{'evp'}->add_timer(@{$timer});
  0            
100             }
101 0 0         if(my $func = $plugin->{'uploader'}) {
102 0           say __PACKAGE__.': adding '. ref($plugin) .' uploader';
103 0           push (@{$self{'uploaders'}}, $func);
  0            
104             }
105 0           foreach my $route (@{$plugin->{'routes'}}) {
  0            
106 0           say __PACKAGE__.': adding ' . ref($plugin) . ' route ' . $route->[0];
107 0           push @{$self{'routes'}}, $route;
  0            
108             }
109 0           $plugin->{'server'} = \%self;
110 0           $self{'loaded_plugins'}{$pluginname} = $plugin;
111             }
112              
113 0           $evp->run();
114              
115 0           return \%self;
116             }
117              
118             sub GetTextResource {
119 0     0 0   my ($self, $filename) = @_;
120 0   0       $self->{'resources'}{$filename} //= read_text_file($filename);
121 0           return \$self->{'resources'}{$filename};
122             }
123              
124             sub onReadReady {
125 0     0 0   my ($server) = @_;
126             # accept the connection
127 0           my $csock = $server->{'sock'}->accept();
128 0 0         if(! $csock) {
129 0           say "server: cannot accept client";
130 0           return 1;
131             }
132              
133             # gather connection details and verify client host is acceptable
134 0           my $peerhost = $csock->peerhost();
135 0 0         if(! $peerhost) {
136 0           say "server: no peerhost";
137 0           return 1;
138             }
139 0           my $peerip = do {
140 0           try { parse_ipv4($peerhost) }
  0            
141             catch ($e) {
142 0           say "server: error parsing ip $peerhost";
143 0           return 1;
144             }
145             };
146 0           my $ah;
147 0           foreach my $allowedHost (@{$server->{'settings'}{'ARIPHOSTS_PARSED'}}) {
  0            
148 0 0         if(($peerip & $allowedHost->{'subnetmask'}) == $allowedHost->{'ip'}) {
149 0           $ah = $allowedHost;
150 0           last;
151             }
152             }
153 0 0         if(!$ah) {
154 0           say "server: $peerhost not allowed";
155 0           return 1;
156             }
157 0           my $peerport = $csock->peerport();
158 0 0         if(! $peerport) {
159 0           say "server: no peerport";
160 0           return 1;
161             }
162              
163             # finally create the client
164 0           say "-------------------------------------------------";
165 0           say "NEW CONN " . $peerhost . ':' . $peerport;
166 0           my $cref = MHFS::HTTP::Server::Client->new($csock, $server, $ah, $peerip);
167 0           return 1;
168             }
169              
170             1;