PVE/HTTPServer.pm

   1 package PVE::HTTPServer;
   2
   3 use strict;
   4 use warnings;
   5 use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
   6 use Socket qw(IPPROTO_TCP TCP_NODELAY SOMAXCONN);
   7 use POSIX qw(strftime EINTR EAGAIN);
   8 use Fcntl;
   9 use IO::File;
  10 use File::stat qw();
  11 use Digest::MD5;
  12 # use AnyEvent::Strict; # only use this for debugging
  13 use AnyEvent::Util qw(guard fh_nonblocking WSAEWOULDBLOCK WSAEINPROGRESS);
  14 use AnyEvent::Socket;
  15 use AnyEvent::Handle;
  16 use AnyEvent::TLS;
  17 use AnyEvent::IO;
  18 use AnyEvent::HTTP;
  19 use Fcntl ();
  20 use Compress::Zlib;
  21 use PVE::SafeSyslog;
  22 use PVE::INotify;
  23 use PVE::RPCEnvironment;
  24 use PVE::REST;
  25
  26 use Net::IP;
  27 use URI;
  28 use HTTP::Status qw(:constants);
  29 use HTTP::Headers;
  30 use HTTP::Response;
  31 use Data::Dumper;
  32
  33 my $limit_max_headers = 30;
  34 my $limit_max_header_size = 8*1024;
  35 my $limit_max_post = 16*1024;
  36
  37
  38 my $known_methods = {
  39     GET => 1,
  40     POST => 1,
  41     PUT => 1,
  42     DELETE => 1,
  43 };
  44
  45 my $baseuri = "/api2";
  46
  47 sub split_abs_uri {
  48     my ($abs_uri) = @_;
  49
  50     my ($format, $rel_uri) = $abs_uri =~ m/^\Q$baseuri\E\/+(html|text|json|extjs|png|htmljs|spiceconfig)(\/.*)?$/;
  51     $rel_uri = '/' if !$rel_uri;
  52
  53     return wantarray ? ($rel_uri, $format) : $rel_uri;
  54 }
  55
  56 sub log_request {
  57     my ($self, $reqstate) = @_;
  58
  59     my $loginfo = $reqstate->{log};
  60
  61     # like apache2 common log format
  62     # LogFormat "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\""
  63
  64     return if $loginfo->{written}; # avoid duplicate logs
  65     $loginfo->{written} = 1;
  66
  67     my $peerip = $reqstate->{peer_host} || '-';
  68     my $userid = $loginfo->{userid} || '-';
  69     my $content_length = defined($loginfo->{content_length}) ? $loginfo->{content_length} : '-';
  70     my $code =  $loginfo->{code} || 500;
  71     my $requestline = $loginfo->{requestline} || '-';
  72     my $timestr = strftime("%d/%b/%Y:%H:%M:%S %z", localtime());
  73
  74     my $msg = "$peerip - $userid [$timestr] \"$requestline\" $code $content_length\n";
  75
  76     $self->write_log($msg);
  77 }
  78
  79 sub log_aborted_request {
  80     my ($self, $reqstate, $error) = @_;
  81
  82     my $r = $reqstate->{request};
  83     return if !$r; # no active request
  84
  85     if ($error) {
  86         syslog("err", "problem with client $reqstate->{peer_host}; $error");
  87     }
  88
  89     $self->log_request($reqstate);
  90 }
  91
  92 sub cleanup_reqstate {
  93     my ($reqstate) = @_;
  94
  95     delete $reqstate->{log};
  96     delete $reqstate->{request};
  97     delete $reqstate->{proto};
  98     delete $reqstate->{accept_gzip};
  99
 100     if ($reqstate->{tmpfilename}) {
 101         unlink $reqstate->{tmpfilename};
 102         delete $reqstate->{tmpfilename};
 103     }
 104 }
 105
 106 sub client_do_disconnect {
 107     my ($self, $reqstate) = @_;
 108
 109     cleanup_reqstate($reqstate);
 110
 111     my $hdl = delete $reqstate->{hdl};
 112
 113     if (!$hdl) {
 114         syslog('err', "detected empty handle");
 115         return;
 116     }
 117
 118     #print "close connection $hdl\n";
 119
 120     shutdown($hdl->{fh}, 1);
 121     # clear all handlers
 122     $hdl->on_drain(undef);
 123     $hdl->on_read(undef);
 124     $hdl->on_eof(undef);
 125     $self->{conn_count}--;
 126
 127     print "$$: CLOSE FH" .  $hdl->{fh}->fileno() . " CONN$self->{conn_count}\n" if $self->{debug};
 128 }
 129
 130 sub finish_response {
 131     my ($self, $reqstate) = @_;
 132
 133     my $hdl = $reqstate->{hdl};
 134
 135     cleanup_reqstate($reqstate);
 136
 137     if (!$self->{end_loop} && $reqstate->{keep_alive} > 0) {
 138         # print "KEEPALIVE $reqstate->{keep_alive}\n" if $self->{debug};
 139         $hdl->on_read(sub {
 140             eval { $self->push_request_header($reqstate); };
 141             warn $@ if $@;
 142         });
 143     } else {
 144         $hdl->on_drain (sub {
 145             eval {
 146                 $self->client_do_disconnect($reqstate);
 147             };
 148             warn $@ if $@;
 149         });
 150     }
 151 }
 152
 153 sub response {
 154     my ($self, $reqstate, $resp, $mtime, $nocomp) = @_;
 155
 156     #print "$$: send response: " . Dumper($resp);
 157
 158     # activate timeout
 159     $reqstate->{hdl}->timeout_reset();
 160     $reqstate->{hdl}->timeout($self->{timeout});
 161
 162     $nocomp = 1 if !$reqstate->{accept_gzip};
 163
 164     my $code = $resp->code;
 165     my $msg = $resp->message || HTTP::Status::status_message($code);
 166     ($msg) = $msg =~m/^(.*)$/m;
 167     my $content = $resp->content;
 168
 169     if ($code =~ /^(1\d\d|[23]04)$/) {
 170         # make sure content we have no content
 171         $content = "";
 172     }
 173
 174     $reqstate->{keep_alive} = 0 if ($code >= 400) || $self->{end_loop};
 175
 176     $reqstate->{log}->{code} = $code;
 177
 178     my $proto = $reqstate->{proto} ? $reqstate->{proto}->{str} : 'HTTP/1.0';
 179     my $res = "$proto $code $msg\015\012";
 180
 181     my $ctime = time();
 182     my $date = HTTP::Date::time2str($ctime);
 183     $resp->header('Date' => $date);
 184     if ($mtime) {
 185         $resp->header('Last-Modified' => HTTP::Date::time2str($mtime));
 186     } else {
 187         $resp->header('Expires' => $date);
 188         $resp->header('Cache-Control' => "max-age=0");
 189         $resp->header("Pragma", "no-cache");
 190     }
 191
 192     $resp->header('Server' => "pve-api-daemon/3.0");
 193
 194     my $content_length;
 195     if ($content) {
 196
 197         $content_length = length($content);
 198
 199         if (!$nocomp && ($content_length > 1024)) {
 200             my $comp = Compress::Zlib::memGzip($content);
 201             $resp->header('Content-Encoding', 'gzip');
 202             $content = $comp;
 203             $content_length = length($content);
 204         }
 205         $resp->header("Content-Length" => $content_length);
 206         $reqstate->{log}->{content_length} = $content_length;
 207
 208     } else {
 209         $resp->remove_header("Content-Length");
 210     }
 211
 212     if ($reqstate->{keep_alive} > 0) {
 213         $resp->push_header('Connection' => 'Keep-Alive');
 214     } else {
 215         $resp->header('Connection' => 'close');
 216     }
 217
 218     $res .= $resp->headers_as_string("\015\012");
 219     #print "SEND(without content) $res\n" if $self->{debug};
 220
 221     $res .= "\015\012";
 222     $res .= $content if $content;
 223
 224     $self->log_request($reqstate, $reqstate->{request});
 225
 226     $reqstate->{hdl}->push_write($res);
 227     $self->finish_response($reqstate);
 228 }
 229
 230 sub error {
 231     my ($self, $reqstate, $code, $msg, $hdr, $content) = @_;
 232
 233     eval {
 234         my $resp = HTTP::Response->new($code, $msg, $hdr, $content);
 235         $self->response($reqstate, $resp);
 236     };
 237     warn $@ if $@;
 238 }
 239
 240 sub send_file_start {
 241     my ($self, $reqstate, $filename) = @_;
 242
 243     eval {
 244         # print "SEND FILE $filename\n";
 245         # Note: aio_load() this is not really async unless we use IO::AIO!
 246         eval {
 247
 248             my $r = $reqstate->{request};
 249
 250             my $fh = IO::File->new($filename, '<') ||
 251                 die "$!\n";
 252             my $stat = File::stat::stat($fh) ||
 253                 die "$!\n";
 254
 255             my $mtime = $stat->mtime;
 256
 257             if (my $ifmod = $r->header('if-modified-since')) {
 258                 my $iftime = HTTP::Date::str2time($ifmod);
 259                 if ($mtime <= $iftime) {
 260                     my $resp = HTTP::Response->new(304, "NOT MODIFIED");
 261                     $self->response($reqstate, $resp, $mtime);
 262                     return;
 263                 }
 264             }
 265
 266             my $data;
 267             my $len = sysread($fh, $data,  $stat->size);
 268             die "got short file\n" if !defined($len) || $len != $stat->size;
 269
 270             my $ct;
 271             my $nocomp;
 272             if ($filename =~ m/\.css$/) {
 273                 $ct = 'text/css';
 274             } elsif ($filename =~ m/\.js$/) {
 275                 $ct = 'application/javascript';
 276             } elsif ($filename =~ m/\.png$/) {
 277                 $ct = 'image/png';
 278                 $nocomp = 1;
 279             } elsif ($filename =~ m/\.gif$/) {
 280                 $ct = 'image/gif';
 281                 $nocomp = 1;
 282             } elsif ($filename =~ m/\.jar$/) {
 283                 $ct = 'application/java-archive';
 284                 $nocomp = 1;
 285             } else {
 286                 die "unable to detect content type";
 287             }
 288
 289             my $header = HTTP::Headers->new(Content_Type => $ct);
 290             my $resp = HTTP::Response->new(200, "OK", $header, $data);
 291             $self->response($reqstate, $resp, $mtime, $nocomp);
 292         };
 293         if (my $err = $@) {
 294             $self->error($reqstate, 501, $err);
 295         }
 296     };
 297
 298     warn $@ if $@;
 299 }
 300
 301 sub proxy_request {
 302     my ($self, $reqstate, $clientip, $host, $method, $uri, $ticket, $token, $params) = @_;
 303
 304     eval {
 305         my $target;
 306         my $keep_alive = 1;
 307         if ($host eq 'localhost') {
 308             $target = "http://$host:85$uri";
 309             # keep alive for localhost is not worth (connection setup is about 0.2ms)
 310             $keep_alive = 0;
 311         } else {
 312             $target = "https://$host:8006$uri";
 313         }
 314
 315         my $headers = {
 316             PVEDisableProxy => 'true',
 317             PVEClientIP => $clientip,
 318         };
 319
 320         my $cookie_name = 'PVEAuthCookie';
 321
 322         $headers->{'cookie'} = PVE::REST::create_auth_cookie($ticket) if $ticket;
 323         $headers->{'CSRFPreventionToken'} = $token if $token;
 324         $headers->{'Accept-Encoding'} = 'gzip' if $reqstate->{accept_gzip};
 325
 326         my $content;
 327
 328         if  ($method eq 'POST' || $method eq 'PUT') {
 329             $headers->{'Content-Type'} = 'application/x-www-form-urlencoded';
 330             # use URI object to format application/x-www-form-urlencoded content.
 331             my $url = URI->new('http:');
 332             $url->query_form(%$params);
 333             $content = $url->query;
 334             if (defined($content)) {
 335                 $headers->{'Content-Length'} = length($content);
 336             }
 337         }
 338
 339         my $w; $w = http_request(
 340             $method => $target,
 341             headers => $headers,
 342             timeout => 30,
 343             recurse => 0,
 344             proxy => undef, # avoid use of $ENV{HTTP_PROXY}
 345             keepalive => $keep_alive,
 346             body => $content,
 347             tls_ctx => $self->{tls_ctx},
 348             sub {
 349                 my ($body, $hdr) = @_;
 350
 351                 undef $w;
 352
 353                 if (!$reqstate->{hdl}) {
 354                     warn "proxy detected vanished client connection\n";
 355                     return;
 356                 }
 357
 358                 eval {
 359                     my $code = delete $hdr->{Status};
 360                     my $msg = delete $hdr->{Reason};
 361                     delete $hdr->{URL};
 362                     delete $hdr->{HTTPVersion};
 363                     my $header = HTTP::Headers->new(%$hdr);
 364                     my $resp = HTTP::Response->new($code, $msg, $header, $body);
 365                     # Note: disable compression, because body is already compressed
 366                     $self->response($reqstate, $resp, undef, 1);
 367                 };
 368                 warn $@ if $@;
 369             });
 370     };
 371     warn $@ if $@;
 372 }
 373
 374 # return arrays as \0 separated strings (like CGI.pm)
 375 sub decode_urlencoded {
 376     my ($data) = @_;
 377
 378     my $res = {};
 379
 380     return $res if !$data;
 381
 382     foreach my $kv (split(/[\&\;]/, $data)) {
 383         my ($k, $v) = split(/=/, $kv);
 384         $k =~s/\+/ /g;
 385         $k =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
 386         $v =~s/\+/ /g;
 387         $v =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
 388
 389         if (defined(my $old = $res->{$k})) {
 390             $res->{$k} = "$old\0$v";
 391         } else {
 392             $res->{$k} = $v;
 393         }
 394     }
 395     return $res;
 396 }
 397
 398 sub extract_params {
 399     my ($r, $method) = @_;
 400
 401     my $params = {};
 402
 403     if ($method eq 'PUT' || $method eq 'POST') {
 404         $params = decode_urlencoded($r->content);
 405     }
 406
 407     my $query_params = decode_urlencoded($r->url->query());
 408
 409     foreach my $k (keys %{$query_params}) {
 410         $params->{$k} = $query_params->{$k};
 411     }
 412
 413     return PVE::Tools::decode_utf8_parameters($params);
 414 }
 415
 416 sub handle_api2_request {
 417     my ($self, $reqstate, $auth, $upload_state) = @_;
 418
 419     eval {
 420         my $r = $reqstate->{request};
 421         my $method = $r->method();
 422         my $path = $r->uri->path();
 423
 424         my ($rel_uri, $format) = split_abs_uri($path);
 425         if (!$format) {
 426             $self->error($reqstate, HTTP_NOT_IMPLEMENTED, "no such uri");
 427             return;
 428         }
 429
 430         #print Dumper($upload_state) if $upload_state;
 431
 432         my $rpcenv = $self->{rpcenv};
 433
 434         my $params;
 435
 436         if ($upload_state) {
 437             $params = $upload_state->{params};
 438         } else {
 439             $params = extract_params($r, $method);
 440         }
 441
 442         delete $params->{_dc}; # remove disable cache parameter
 443
 444         my $clientip = $reqstate->{peer_host};
 445
 446         $rpcenv->init_request();
 447
 448         my $res = PVE::REST::rest_handler($rpcenv, $clientip, $method, $rel_uri, $auth, $params);
 449
 450         AnyEvent->now_update(); # in case somebody called sleep()
 451
 452         $rpcenv->set_user(undef); # clear after request
 453
 454         if ($res->{proxy}) {
 455
 456             if ($self->{trusted_env}) {
 457                 $self->error($reqstate, HTTP_INTERNAL_SERVER_ERROR, "proxy not allowed");
 458                 return;
 459             }
 460
 461             $res->{proxy_params}->{tmpfilename} = $reqstate->{tmpfilename} if $upload_state;
 462
 463             $self->proxy_request($reqstate, $clientip, $res->{proxy}, $method,
 464                                  $r->uri, $auth->{ticket}, $auth->{token}, $res->{proxy_params});
 465             return;
 466
 467         }
 468
 469         PVE::REST::prepare_response_data($format, $res);
 470         my ($raw, $ct, $nocomp) = PVE::REST::format_response_data($format, $res, $path);
 471
 472         my $resp = HTTP::Response->new($res->{status}, $res->{message});
 473         $resp->header("Content-Type" => $ct);
 474         $resp->content($raw);
 475         $self->response($reqstate, $resp, $nocomp);
 476     };
 477     if (my $err = $@) {
 478         $self->error($reqstate, 501, $err);
 479     }
 480 }
 481
 482 sub handle_spice_proxy_request {
 483     my ($self, $reqstate, $vmid, $node) = @_;
 484
 485     eval {
 486
 487         my $remip;
 488
 489         if ($node ne 'localhost' && $node ne PVE::INotify::nodename()) {
 490             $remip = PVE::Cluster::remote_node_ip($node);
 491             die "unable to get remote IP address for none '$node'\n";
 492         }
 493
 494         if ($remip) {
 495             die "not implemented";
 496
 497             return;
 498         }
 499
 500         $reqstate->{hdl}->timeout(0);
 501
 502         # local node
 503         my $socket = PVE::QemuServer::spice_socket($vmid);
 504
 505         print "$$: CONNECT $vmid, $node, $socket\n" if $self->{debug};
 506
 507         # fixme: this needs root privs
 508         tcp_connect "unix/", $socket, sub {
 509             my ($fh) = @_
 510                 or die "connect to '$socket' failed: $!";
 511
 512             print "$$: CONNECTed to $socket\n" if $self->{debug};
 513             $reqstate->{proxyhdl} = AnyEvent::Handle->new(
 514                 fh => $fh,
 515                 rbuf_max => 64*1024,
 516                 wbuf_max => 64*10*1024,
 517                 timeout => 0,
 518                 #linger => 0, # avoid problems with ssh - really needed ?
 519                 on_eof => sub {
 520                     my ($hdl) = @_;
 521                     eval {
 522                         $self->log_aborted_request($reqstate);
 523                         $self->client_do_disconnect($reqstate);
 524                     };
 525                     if (my $err = $@) { syslog('err', $err); }
 526                 },
 527                 on_error => sub {
 528                     my ($hdl, $fatal, $message) = @_;
 529                     eval {
 530                         $self->log_aborted_request($reqstate, $message);
 531                         $self->client_do_disconnect($reqstate);
 532                     };
 533                     if (my $err = $@) { syslog('err', "$err"); }
 534                 },
 535                 on_read => sub {
 536                     my ($hdl) = @_;
 537
 538                     my $len = length($hdl->{rbuf});
 539                     my $data = substr($hdl->{rbuf}, 0, $len, '');
 540
 541                     #print "READ1 $len\n";
 542                     $reqstate->{hdl}->push_write($data) if $reqstate->{hdl};
 543                 });
 544
 545             $reqstate->{hdl}->on_read(sub {
 546                 my ($hdl) = @_;
 547
 548                 my $len = length($hdl->{rbuf});
 549                 my $data = substr($hdl->{rbuf}, 0, $len, '');
 550
 551                 #print "READ0 $len\n";
 552                 $reqstate->{proxyhdl}->push_write($data) if $reqstate->{proxyhdl};
 553             });
 554
 555             $reqstate->{hdl}->wbuf_max(64*10*1024);
 556
 557             # fixme: use stop_read/start_read if write buffer grows to much
 558
 559             my $proto = $reqstate->{proto} ? $reqstate->{proto}->{str} : 'HTTP/1.0';
 560             my $res = "$proto 200 OK\015\012"; # hope this is the right answer?
 561             $reqstate->{hdl}->push_write($res);
 562
 563             # log early
 564             $reqstate->{log}->{code} = 200;
 565             $self->log_request($reqstate);
 566         };
 567     };
 568     if (my $err = $@) {
 569         $self->log_aborted_request($reqstate, $err);
 570         $self->client_do_disconnect($reqstate);
 571     }
 572 }
 573
 574 sub handle_request {
 575     my ($self, $reqstate, $auth) = @_;
 576
 577     eval {
 578         my $r = $reqstate->{request};
 579         my $method = $r->method();
 580         my $path = $r->uri->path();
 581
 582         # disable timeout on handle (we already have all data we need)
 583         # we re-enable timeout in response()
 584         $reqstate->{hdl}->timeout(0);
 585
 586         if ($path =~ m!$baseuri!) {
 587             $self->handle_api2_request($reqstate, $auth);
 588             return;
 589         }
 590
 591         if ($self->{pages} && ($method eq 'GET') && (my $handler = $self->{pages}->{$path})) {
 592             if (ref($handler) eq 'CODE') {
 593                 my $params = decode_urlencoded($r->url->query());
 594                 my ($resp, $userid) = &$handler($self, $reqstate->{request}, $params);
 595                 $self->response($reqstate, $resp);
 596             } elsif (ref($handler) eq 'HASH') {
 597                 if (my $filename = $handler->{file}) {
 598                     my $fh = IO::File->new($filename) ||
 599                         die "unable to open file '$filename' - $!\n";
 600                     send_file_start($self, $reqstate, $filename);
 601                 } else {
 602                     die "internal error - no handler";
 603                 }
 604             } else {
 605                 die "internal error - no handler";
 606             }
 607             return;
 608         }
 609
 610         if ($self->{dirs} && ($method eq 'GET')) {
 611             # we only allow simple names
 612             if ($path =~ m!^(/\S+/)([a-zA-Z0-9\-\_\.]+)$!) {
 613                 my ($subdir, $file) = ($1, $2);
 614                 if (my $dir = $self->{dirs}->{$subdir}) {
 615                     my $filename = "$dir$file";
 616                     my $fh = IO::File->new($filename) ||
 617                         die "unable to open file '$filename' - $!\n";
 618                     send_file_start($self, $reqstate, $filename);
 619                     return;
 620                 }
 621             }
 622         }
 623
 624         die "no such file '$path'";
 625     };
 626     if (my $err = $@) {
 627         $self->error($reqstate, 501, $err);
 628     }
 629 }
 630
 631 sub file_upload_multipart {
 632     my ($self, $reqstate, $auth, $rstate) = @_;
 633
 634     eval {
 635         my $boundary = $rstate->{boundary};
 636         my $hdl = $reqstate->{hdl};
 637
 638         my $startlen = length($hdl->{rbuf});
 639
 640         if ($rstate->{phase} == 0) { # skip everything until start
 641             if ($hdl->{rbuf} =~ s/^.*?--\Q$boundary\E  \015?\012
 642                        ((?:[^\015]+\015\012)* ) \015?\012//xs) {
 643                 my $header = $1;
 644                 my ($ct, $disp, $name, $filename);
 645                 foreach my $line (split(/\015?\012/, $header)) {
 646                     # assume we have single line headers
 647                     if ($line =~ m/^Content-Type\s*:\s*(.*)/i) {
 648                         $ct = parse_content_type($1);
 649                     } elsif ($line =~ m/^Content-Disposition\s*:\s*(.*)/i) {
 650                         ($disp, $name, $filename) = parse_content_disposition($1);
 651                     }
 652                 }
 653
 654                 if (!($disp && $disp eq 'form-data' && $name)) {
 655                     syslog('err', "wrong content disposition in multipart - abort upload");
 656                     $rstate->{phase} = -1;
 657                 } else {
 658
 659                     $rstate->{fieldname} = $name;
 660
 661                     if ($filename) {
 662                         if ($name eq 'filename') {
 663                             # found file upload data
 664                             $rstate->{phase} = 1;
 665                             $rstate->{filename} = $filename;
 666                         } else {
 667                             syslog('err', "wrong field name for file upload - abort upload");
 668                             $rstate->{phase} = -1;
 669                         }
 670                     } else {
 671                         # found form data for field $name
 672                         $rstate->{phase} = 2;
 673                     }
 674                 }
 675             } else {
 676                 my $len = length($hdl->{rbuf});
 677                 substr($hdl->{rbuf}, 0, $len - $rstate->{maxheader}, '')
 678                     if $len > $rstate->{maxheader}; # skip garbage
 679             }
 680         } elsif ($rstate->{phase} == 1) { # inside file - dump until end marker
 681             if ($hdl->{rbuf} =~ s/^(.*?)\015?\012(--\Q$boundary\E(--)? \015?\012(.*))$/$2/xs) {
 682                 my ($rest, $eof) = ($1, $3);
 683                 my $len = length($rest);
 684                 die "write to temporary file failed - $!"
 685                     if syswrite($rstate->{outfh}, $rest) != $len;
 686                 $rstate->{ctx}->add($rest);
 687                 $rstate->{params}->{filename} = $rstate->{filename};
 688                 $rstate->{md5sum} = $rstate->{ctx}->hexdigest;
 689                 $rstate->{bytes} += $len;
 690                 $rstate->{phase} =  $eof ? 100 : 0;
 691             } else {
 692                 my $len = length($hdl->{rbuf});
 693                 my $wlen = $len - $rstate->{boundlen};
 694                 if ($wlen > 0) {
 695                     my $data = substr($hdl->{rbuf}, 0, $wlen, '');
 696                     die "write to temporary file failed - $!"
 697                         if syswrite($rstate->{outfh}, $data) != $wlen;
 698                     $rstate->{bytes} += $wlen;
 699                     $rstate->{ctx}->add($data);
 700                 }
 701             }
 702         } elsif ($rstate->{phase} == 2) { # inside normal field
 703
 704             if ($hdl->{rbuf} =~ s/^(.*?)\015?\012(--\Q$boundary\E(--)? \015?\012(.*))$/$2/xs) {
 705                 my ($rest, $eof) = ($1, $3);
 706                 my $len = length($rest);
 707                 $rstate->{post_size} += $len;
 708                 if ($rstate->{post_size} < $limit_max_post) {
 709                     $rstate->{params}->{$rstate->{fieldname}} = $rest;
 710                     $rstate->{phase} = $eof ? 100 : 0;
 711                 } else {
 712                     syslog('err', "form data to large - abort upload");
 713                     $rstate->{phase} = -1; # skip
 714                 }
 715             }
 716         } else { # skip
 717             my $len = length($hdl->{rbuf});
 718             substr($hdl->{rbuf}, 0, $len, ''); # empty rbuf
 719         }
 720
 721         $rstate->{read} += ($startlen - length($hdl->{rbuf}));
 722
 723         if (!$rstate->{done} && ($rstate->{read} + length($hdl->{rbuf})) >= $rstate->{size}) {
 724             $rstate->{done} = 1; # make sure we dont get called twice
 725             if ($rstate->{phase} < 0 || !$rstate->{md5sum}) {
 726                 die "upload failed\n";
 727             } else {
 728                 my $elapsed = tv_interval($rstate->{starttime});
 729
 730                 my $rate = int($rstate->{bytes}/($elapsed*1024*1024));
 731                 syslog('info', "multipart upload complete " .
 732                        "(size: %d time: %ds rate: %.2fMiB/s md5sum: $rstate->{md5sum})",
 733                        $rstate->{bytes}, $elapsed, $rate);
 734                 $self->handle_api2_request($reqstate, $auth, $rstate);
 735             }
 736         }
 737     };
 738     if (my $err = $@) {
 739         syslog('err', $err);
 740         $self->error($reqstate, 501, $err);
 741     }
 742 }
 743
 744 sub parse_content_type {
 745     my ($ctype) = @_;
 746
 747     my ($ct, @params) = split(/\s*[;,]\s*/o, $ctype);
 748
 749     foreach my $v (@params) {
 750         if ($v =~ m/^\s*boundary\s*=\s*(\S+?)\s*$/o) {
 751             return wantarray ? ($ct, $1) : $ct;
 752         }
 753     }
 754
 755     return  wantarray ? ($ct) : $ct;
 756 }
 757
 758 sub parse_content_disposition {
 759     my ($line) = @_;
 760
 761     my ($disp, @params) = split(/\s*[;,]\s*/o, $line);
 762     my $name;
 763     my $filename;
 764
 765     foreach my $v (@params) {
 766         if ($v =~ m/^\s*name\s*=\s*(\S+?)\s*$/o) {
 767             $name = $1;
 768             $name =~ s/^"(.*)"$/$1/;
 769         } elsif ($v =~ m/^\s*filename\s*=\s*(.+?)\s*$/o) {
 770             $filename = $1;
 771             $filename =~ s/^"(.*)"$/$1/;
 772         }
 773     }
 774
 775     return  wantarray ? ($disp, $name, $filename) : $disp;
 776 }
 777
 778 my $tmpfile_seq_no = 0;
 779
 780 sub get_upload_filename {
 781     # choose unpredictable tmpfile name
 782
 783     $tmpfile_seq_no++;
 784     return "/var/tmp/pveupload-" . Digest::MD5::md5_hex($tmpfile_seq_no . time() . $$);
 785 }
 786
 787 sub unshift_read_header {
 788     my ($self, $reqstate, $state) = @_;
 789
 790     $state = { size => 0, count => 0 } if !$state;
 791
 792     $reqstate->{hdl}->unshift_read(line => sub {
 793         my ($hdl, $line) = @_;
 794
 795         eval {
 796             # print "$$: got header: $line\n" if $self->{debug};
 797
 798             die "to many http header lines\n" if ++$state->{count} >= $limit_max_headers;
 799             die "http header too large\n" if ($state->{size} += length($line)) >= $limit_max_header_size;
 800
 801             my $r = $reqstate->{request};
 802             if ($line eq '') {
 803
 804                 my $path = $r->uri->path();
 805                 my $method = $r->method();
 806
 807                 $r->push_header($state->{key}, $state->{val})
 808                     if $state->{key};
 809
 810                 if (!$known_methods->{$method}) {
 811                     my $resp = HTTP::Response->new(HTTP_NOT_IMPLEMENTED, "method '$method' not available");
 812                     $self->response($reqstate, $resp);
 813                     return;
 814                 }
 815
 816                 my $conn = $r->header('Connection');
 817                 my $accept_enc = $r->header('Accept-Encoding');
 818                 $reqstate->{accept_gzip} = ($accept_enc && $accept_enc =~ m/gzip/) ? 1 : 0;
 819
 820                 if ($conn) {
 821                     $reqstate->{keep_alive} = 0 if $conn =~ m/close/oi;
 822                 } else {
 823                     if ($reqstate->{proto}->{ver} < 1001) {
 824                         $reqstate->{keep_alive} = 0;
 825                     }
 826                 }
 827
 828                 my $te  = $r->header('Transfer-Encoding');
 829                 if ($te && lc($te) eq 'chunked') {
 830                     # Handle chunked transfer encoding
 831                     $self->error($reqstate, 501, "chunked transfer encoding not supported");
 832                     return;
 833                 } elsif ($te) {
 834                     $self->error($reqstate, 501, "Unknown transfer encoding '$te'");
 835                     return;
 836                 }
 837
 838                 my $pveclientip = $r->header('PVEClientIP');
 839
 840                 # fixme: how can we make PVEClientIP header trusted?
 841                 if ($self->{trusted_env} && $pveclientip) {
 842                     $reqstate->{peer_host} = $pveclientip;
 843                 } else {
 844                     $r->header('PVEClientIP', $reqstate->{peer_host});
 845                 }
 846
 847                 my $len = $r->header('Content-Length');
 848
 849                 # header processing complete - authenticate now
 850
 851                 my $auth = {};
 852                 if ($self->{spiceproxy}) {
 853                     my $connect_str = $r->header('Host');
 854                     my ($vmid, $node) = PVE::AccessControl::verify_spice_connect_url($connect_str);
 855                     if (!($vmid && $node)) {
 856                         $self->error($reqstate, HTTP_UNAUTHORIZED, "invalid ticket");
 857                         return;
 858                     }
 859                     $self->handle_spice_proxy_request($reqstate, $vmid, $node);
 860                     return;
 861                 } elsif ($path =~ m!$baseuri!) {
 862                     my $token = $r->header('CSRFPreventionToken');
 863                     my $cookie = $r->header('Cookie');
 864                     my $ticket = PVE::REST::extract_auth_cookie($cookie);
 865
 866                     my ($rel_uri, $format) = split_abs_uri($path);
 867                     if (!$format) {
 868                         $self->error($reqstate, HTTP_NOT_IMPLEMENTED, "no such uri");
 869                         return;
 870                     }
 871
 872                     eval {
 873                         $auth = PVE::REST::auth_handler($self->{rpcenv}, $reqstate->{peer_host}, $method,
 874                                                         $rel_uri, $ticket, $token);
 875                     };
 876                     if (my $err = $@) {
 877                         $self->error($reqstate, HTTP_UNAUTHORIZED, $err);
 878                         return;
 879                     }
 880                 }
 881
 882                 $reqstate->{log}->{userid} = $auth->{userid};
 883
 884                 if ($len) {
 885
 886                     if (!($method eq 'PUT' || $method eq 'POST')) {
 887                         $self->error($reqstate, 501, "Unexpected content for method '$method'");
 888                         return;
 889                     }
 890
 891                     my $ctype = $r->header('Content-Type');
 892                     my ($ct, $boundary) = parse_content_type($ctype) if $ctype;
 893
 894                     if ($auth->{isUpload} && !$self->{trusted_env}) {
 895                         die "upload 'Content-Type '$ctype' not implemented\n"
 896                             if !($boundary && $ct && ($ct eq 'multipart/form-data'));
 897
 898                         die "upload without content length header not supported" if !$len;
 899
 900                         die "upload without content length header not supported" if !$len;
 901
 902                         print "start upload $path $ct $boundary\n" if $self->{debug};
 903
 904                         my $tmpfilename = get_upload_filename();
 905                         my $outfh = IO::File->new($tmpfilename, O_RDWR|O_CREAT|O_EXCL, 0600) ||
 906                             die "unable to create temporary upload file '$tmpfilename'";
 907
 908                         $reqstate->{keep_alive} = 0;
 909
 910                         my $boundlen = length($boundary) + 8; # \015?\012--$boundary--\015?\012
 911
 912                         my $state = {
 913                             size => $len,
 914                             boundary => $boundary,
 915                             ctx => Digest::MD5->new,
 916                             boundlen =>  $boundlen,
 917                             maxheader => 2048 + $boundlen, # should be large enough
 918                             params => decode_urlencoded($r->url->query()),
 919                             phase => 0,
 920                             read => 0,
 921                             post_size => 0,
 922                             starttime => [gettimeofday],
 923                             outfh => $outfh,
 924                         };
 925                         $reqstate->{tmpfilename} = $tmpfilename;
 926                         $reqstate->{hdl}->on_read(sub { $self->file_upload_multipart($reqstate, $auth, $state); });
 927                         return;
 928                     }
 929
 930                     if ($len > $limit_max_post) {
 931                         $self->error($reqstate, 501, "for data too large");
 932                         return;
 933                     }
 934
 935                     if (!$ct || $ct eq 'application/x-www-form-urlencoded') {
 936                         $reqstate->{hdl}->unshift_read(chunk => $len, sub {
 937                             my ($hdl, $data) = @_;
 938                             $r->content($data);
 939                             $self->handle_request($reqstate, $auth);
 940                         });
 941                     } else {
 942                         $self->error($reqstate, 506, "upload 'Content-Type '$ctype' not implemented");
 943                     }
 944                 } else {
 945                     $self->handle_request($reqstate, $auth);
 946                 }
 947             } elsif ($line =~ /^([^:\s]+)\s*:\s*(.*)/) {
 948                 $r->push_header($state->{key}, $state->{val}) if $state->{key};
 949                 ($state->{key}, $state->{val}) = ($1, $2);
 950                 $self->unshift_read_header($reqstate, $state);
 951             } elsif ($line =~ /^\s+(.*)/) {
 952                 $state->{val} .= " $1";
 953                 $self->unshift_read_header($reqstate, $state);
 954             } else {
 955                 $self->error($reqstate, 506, "unable to parse request header");
 956             }
 957         };
 958         warn $@ if $@;
 959     });
 960 };
 961
 962 sub push_request_header {
 963     my ($self, $reqstate) = @_;
 964
 965     eval {
 966         $reqstate->{hdl}->push_read(line => sub {
 967             my ($hdl, $line) = @_;
 968
 969             eval {
 970                 #print "got request header: $line\n" if $self->{debug};
 971
 972                 $reqstate->{keep_alive}--;
 973
 974                 if ($line =~ /(\S+)\040(\S+)\040HTTP\/(\d+)\.(\d+)/o) {
 975                     my ($method, $uri, $maj, $min) = ($1, $2, $3, $4);
 976
 977                     if ($maj != 1) {
 978                         $self->error($reqstate, 506, "http protocol version $maj.$min not supported");
 979                         return;
 980                     }
 981
 982                     $self->{request_count}++; # only count valid request headers
 983                     if ($self->{request_count} >= $self->{max_requests}) {
 984                         $self->{end_loop} = 1;
 985                     }
 986                     $reqstate->{log} = { requestline => $line };
 987                     $reqstate->{proto}->{str} = "HTTP/$maj.$min";
 988                     $reqstate->{proto}->{maj} = $maj;
 989                     $reqstate->{proto}->{min} = $min;
 990                     $reqstate->{proto}->{ver} = $maj*1000+$min;
 991                     $reqstate->{request} = HTTP::Request->new($method, $uri);
 992
 993                     $self->unshift_read_header($reqstate);
 994                 } elsif ($line eq '') {
 995                     # ignore empty lines before requests (browser bugs?)
 996                     $self->push_request_header($reqstate);
 997                 } else {
 998                     $self->error($reqstate, 400, 'bad request');
 999                 }
1000             };
1001             warn $@ if $@;
1002         });
1003     };
1004     warn $@ if $@;
1005 }
1006
1007 sub accept {
1008     my ($self) = @_;
1009
1010     my $clientfh;
1011
1012     return if $self->{end_loop};
1013
1014     # we need to m make sure that only one process calls accept
1015     while (!flock($self->{lockfh}, Fcntl::LOCK_EX())) {
1016         next if $! == EINTR;
1017         die "could not get lock on file '$self->{lockfile}' -  $!\n";
1018     }
1019
1020     my $again = 0;
1021     my $errmsg;
1022     eval {
1023         while (!$self->{end_loop} &&
1024                !defined($clientfh = $self->{socket}->accept()) &&
1025                ($! == EINTR)) {};
1026
1027         if ($self->{end_loop}) {
1028             $again = 0;
1029         } else {
1030             $again = ($! == EAGAIN || $! == WSAEWOULDBLOCK);
1031             if (!defined($clientfh)) {
1032                 $errmsg = "failed to accept connection: $!\n";
1033             }
1034         }
1035     };
1036     warn $@ if $@;
1037
1038     flock($self->{lockfh}, Fcntl::LOCK_UN());
1039
1040     if (!defined($clientfh)) {
1041         return if $again;
1042         die $errmsg if $errmsg;
1043     }
1044
1045     fh_nonblocking $clientfh, 1;
1046
1047     $self->{conn_count}++;
1048
1049     return $clientfh;
1050 }
1051
1052 sub wait_end_loop {
1053     my ($self) = @_;
1054
1055     $self->{end_loop} = 1;
1056
1057     undef $self->{socket_watch};
1058
1059     if ($self->{conn_count} <= 0) {
1060         $self->{end_cond}->send(1);
1061         return;
1062     }
1063
1064     # else we need to wait until all open connections gets closed
1065     my $w; $w = AnyEvent->timer (after => 1, interval => 1, cb => sub {
1066         eval {
1067             # todo: test for active connections instead (we can abort idle connections)
1068             if ($self->{conn_count} <= 0) {
1069                 undef $w;
1070                 $self->{end_cond}->send(1);
1071             }
1072         };
1073         warn $@ if $@;
1074     });
1075 }
1076
1077
1078 sub check_host_access {
1079     my ($self, $clientip) = @_;
1080
1081     my $cip = Net::IP->new($clientip);
1082
1083     my $match_allow = 0;
1084     my $match_deny = 0;
1085
1086     if ($self->{allow_from}) {
1087         foreach my $t (@{$self->{allow_from}}) {
1088             if ($t->overlaps($cip)) {
1089                 $match_allow = 1;
1090                 last;
1091             }
1092         }
1093     }
1094
1095     if ($self->{deny_from}) {
1096         foreach my $t (@{$self->{deny_from}}) {
1097             if ($t->overlaps($cip)) {
1098                 $match_deny = 1;
1099                 last;
1100             }
1101         }
1102     }
1103
1104     if ($match_allow == $match_deny) {
1105         # match both allow and deny, or no match
1106         return $self->{policy} && $self->{policy} eq 'allow' ? 1 : 0;
1107     }
1108
1109     return $match_allow;
1110 }
1111
1112 sub accept_connections {
1113     my ($self) = @_;
1114
1115     eval {
1116
1117         while (my $clientfh = $self->accept()) {
1118
1119             my $reqstate = { keep_alive => $self->{keep_alive} };
1120
1121             # stop keep-alive when there are many open connections
1122             if ($self->{conn_count} >= $self->{max_conn_soft_limit}) {
1123                 $reqstate->{keep_alive} = 0;
1124             }
1125
1126             if (my $sin = getpeername($clientfh)) {
1127                 my ($pport, $phost) = Socket::unpack_sockaddr_in($sin);
1128                 ($reqstate->{peer_port}, $reqstate->{peer_host}) = ($pport,  Socket::inet_ntoa($phost));
1129             }
1130
1131             if (!$self->{trusted_env} && !$self->check_host_access($reqstate->{peer_host})) {
1132                 print "$$: ABORT request from $reqstate->{peer_host} - access denied\n" if $self->{debug};
1133                 $reqstate->{log}->{code} = 403;
1134                 $self->log_request($reqstate);
1135                 next;
1136             }
1137
1138             $reqstate->{hdl} = AnyEvent::Handle->new(
1139                 fh => $clientfh,
1140                 rbuf_max => 64*1024,
1141                 timeout => $self->{timeout},
1142                 linger => 0, # avoid problems with ssh - really needed ?
1143                 on_eof   => sub {
1144                     my ($hdl) = @_;
1145                     eval {
1146                         $self->log_aborted_request($reqstate);
1147                         $self->client_do_disconnect($reqstate);
1148                     };
1149                     if (my $err = $@) { syslog('err', $err); }
1150                 },
1151                 on_error => sub {
1152                     my ($hdl, $fatal, $message) = @_;
1153                     eval {
1154                         $self->log_aborted_request($reqstate, $message);
1155                         $self->client_do_disconnect($reqstate);
1156                     };
1157                     if (my $err = $@) { syslog('err', "$err"); }
1158                 },
1159                 ($self->{tls_ctx} ? (tls => "accept", tls_ctx => $self->{tls_ctx}) : ()));
1160
1161             print "$$: ACCEPT FH" .  $clientfh->fileno() . " CONN$self->{conn_count}\n" if $self->{debug};
1162
1163             $self->push_request_header($reqstate);
1164         }
1165     };
1166
1167     if (my $err = $@) {
1168         syslog('err', $err);
1169         $self->{end_loop} = 1;
1170     }
1171
1172     $self->wait_end_loop() if $self->{end_loop};
1173 }
1174
1175 # Note: We can't open log file in non-blocking mode and use AnyEvent::Handle,
1176 # because we write from multiple processes, and that would arbitrarily mix output
1177 # of all processes.
1178 sub open_access_log {
1179     my ($self, $filename) = @_;
1180
1181     my $old_mask = umask(0137);;
1182     my $logfh = IO::File->new($filename, ">>") ||
1183         die "unable to open log file '$filename' - $!\n";
1184     umask($old_mask);
1185
1186     $logfh->autoflush(1);
1187
1188     $self->{logfh} = $logfh;
1189 }
1190
1191 sub write_log {
1192     my ($self, $data) = @_;
1193
1194     return if !defined($self->{logfh}) || !$data;
1195
1196     my $res = $self->{logfh}->print($data);
1197
1198     if (!$res) {
1199         delete $self->{logfh};
1200         syslog('err', "error writing access log");
1201         $self->{end_loop} = 1; # terminate asap
1202     }
1203 }
1204
1205 sub atfork_handler {
1206     my ($self) = @_;
1207
1208     eval {
1209         # something else do to ?
1210         close($self->{socket});
1211     };
1212     warn $@ if $@;
1213 }
1214
1215 sub new {
1216     my ($this, %args) = @_;
1217
1218     my $class = ref($this) || $this;
1219
1220     foreach my $req (qw(socket lockfh lockfile)) {
1221         die "misssing required argument '$req'" if !defined($args{$req});
1222     }
1223
1224     my $self = bless { %args }, $class;
1225
1226     # init inotify
1227     PVE::INotify::inotify_init();
1228
1229     $self->{rpcenv} = PVE::RPCEnvironment->init(
1230         $self->{trusted_env} ? 'priv' : 'pub', atfork =>  sub { $self-> atfork_handler() });
1231
1232     fh_nonblocking($self->{socket}, 1);
1233
1234     $self->{end_loop} = 0;
1235     $self->{conn_count} = 0;
1236     $self->{request_count} = 0;
1237     $self->{timeout} = 5 if !$self->{timeout};
1238     $self->{keep_alive} = 0 if !defined($self->{keep_alive});
1239     $self->{max_conn} = 800 if !$self->{max_conn};
1240     $self->{max_requests} = 8000 if !$self->{max_requests};
1241
1242     $self->{policy} = 'allow' if !$self->{policy};
1243
1244     $self->{end_cond} = AnyEvent->condvar;
1245
1246     if ($self->{ssl}) {
1247         $self->{tls_ctx} = AnyEvent::TLS->new(%{$self->{ssl}});
1248     }
1249
1250     if ($self->{spiceproxy}) {
1251         $known_methods = { CONNECT => 1 };
1252     }
1253
1254     $self->open_access_log($self->{logfile}) if $self->{logfile};
1255
1256     $self->{max_conn_soft_limit} = $self->{max_conn} > 100 ? $self->{max_conn} - 20 : $self->{max_conn};
1257
1258     $self->{socket_watch} = AnyEvent->io(fh => $self->{socket}, poll => 'r', cb => sub {
1259         eval {
1260             if ($self->{conn_count} >= $self->{max_conn}) {
1261                 my $w; $w = AnyEvent->timer (after => 1, interval => 1, cb => sub {
1262                     if ($self->{conn_count} < $self->{max_conn}) {
1263                         undef $w;
1264                         $self->accept_connections();
1265                     }
1266                 });
1267             } else {
1268                 $self->accept_connections();
1269             }
1270         };
1271         warn $@ if $@;
1272     });
1273
1274     $self->{term_watch} = AnyEvent->signal(signal => "TERM", cb => sub {
1275         undef $self->{term_watch};
1276         $self->wait_end_loop();
1277     });
1278
1279     $self->{quit_watch} = AnyEvent->signal(signal => "QUIT", cb => sub {
1280         undef $self->{quit_watch};
1281         $self->wait_end_loop();
1282     });
1283
1284     $self->{inotify_poll} = AnyEvent->timer(after => 5, interval => 5, cb => sub {
1285         PVE::INotify::poll(); # read inotify events
1286     });
1287
1288     return $self;
1289 }
1290
1291 sub run {
1292     my ($self) = @_;
1293
1294     $self->{end_cond}->recv;
1295 }
1296
1297 1;