PVE/APIServer/AnyEvent.pm

   1 package PVE::APIServer::AnyEvent;
   2
   3 # Note 1: interactions with Crypt::OpenSSL::RSA
   4 #
   5 # Some handlers (auth_handler) use Crypt::OpenSSL::RSA, which seems to
   6 # set the openssl error variable. We need to clear that here, else
   7 # AnyEvent::TLS aborts the connection.
   8 # Net::SSLeay::ERR_clear_error();
   9
  10 use strict;
  11 use warnings;
  12 use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
  13 use Socket qw(IPPROTO_TCP TCP_NODELAY SOMAXCONN);
  14 use POSIX qw(strftime EINTR EAGAIN);
  15 use Fcntl;
  16 use IO::File;
  17 use File::stat qw();
  18 use File::Find;
  19 use MIME::Base64;
  20 use Digest::MD5;
  21 use Digest::SHA;
  22 # use AnyEvent::Strict; # only use this for debugging
  23 use AnyEvent::Util qw(guard fh_nonblocking WSAEWOULDBLOCK WSAEINPROGRESS);
  24 use AnyEvent::Socket;
  25 use AnyEvent::Handle;
  26 use Net::SSLeay;
  27 use AnyEvent::TLS;
  28 use AnyEvent::IO;
  29 use AnyEvent::HTTP;
  30 use Fcntl ();
  31 use Compress::Zlib;
  32 use Encode;
  33 use PVE::SafeSyslog;
  34 use PVE::INotify;
  35 use PVE::Tools;
  36 use PVE::APIServer::Formatter;
  37
  38 use Net::IP;
  39 use URI;
  40 use URI::Escape;
  41 use HTTP::Status qw(:constants);
  42 use HTTP::Date;
  43 use HTTP::Headers;
  44 use HTTP::Request;
  45 use HTTP::Response;
  46 use Data::Dumper;
  47 use JSON;
  48
  49 my $limit_max_headers = 64;
  50 my $limit_max_header_size = 8*1024;
  51 my $limit_max_post = 64*1024;
  52
  53 my $known_methods = {
  54     GET => 1,
  55     POST => 1,
  56     PUT => 1,
  57     DELETE => 1,
  58 };
  59
  60 my $split_abs_uri = sub {
  61     my ($abs_uri, $base_uri) = @_;
  62
  63     my ($format, $rel_uri) = $abs_uri =~ m/^\Q$base_uri\E\/+([a-z][a-z0-9]+)(\/.*)?$/;
  64     $rel_uri = '/' if !$rel_uri;
  65
  66     return wantarray ? ($rel_uri, $format) : $rel_uri;
  67 };
  68
  69 sub log_request {
  70     my ($self, $reqstate) = @_;
  71
  72     my $loginfo = $reqstate->{log};
  73
  74     # like apache2 common log format
  75     # LogFormat "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\""
  76
  77     return if $loginfo->{written}; # avoid duplicate logs
  78     $loginfo->{written} = 1;
  79
  80     my $peerip = $reqstate->{peer_host} || '-';
  81     my $userid = $loginfo->{userid} || '-';
  82     my $content_length = defined($loginfo->{content_length}) ? $loginfo->{content_length} : '-';
  83     my $code =  $loginfo->{code} || 500;
  84     my $requestline = $loginfo->{requestline} || '-';
  85     my $timestr = strftime("%d/%m/%Y:%H:%M:%S %z", localtime());
  86
  87     my $msg = "$peerip - $userid [$timestr] \"$requestline\" $code $content_length\n";
  88
  89     $self->write_log($msg);
  90 }
  91
  92 sub log_aborted_request {
  93     my ($self, $reqstate, $error) = @_;
  94
  95     my $r = $reqstate->{request};
  96     return if !$r; # no active request
  97
  98     if ($error) {
  99         syslog("err", "problem with client $reqstate->{peer_host}; $error");
 100     }
 101
 102     $self->log_request($reqstate);
 103 }
 104
 105 sub cleanup_reqstate {
 106     my ($reqstate) = @_;
 107
 108     delete $reqstate->{log};
 109     delete $reqstate->{request};
 110     delete $reqstate->{proto};
 111     delete $reqstate->{accept_gzip};
 112     delete $reqstate->{starttime};
 113
 114     if ($reqstate->{tmpfilename}) {
 115         unlink $reqstate->{tmpfilename};
 116         delete $reqstate->{tmpfilename};
 117     }
 118 }
 119
 120 sub client_do_disconnect {
 121     my ($self, $reqstate) = @_;
 122
 123     cleanup_reqstate($reqstate);
 124
 125     my $shutdown_hdl = sub {
 126         my $hdl = shift;
 127
 128         shutdown($hdl->{fh}, 1);
 129         # clear all handlers
 130         $hdl->on_drain(undef);
 131         $hdl->on_read(undef);
 132         $hdl->on_eof(undef);
 133     };
 134
 135     if (my $proxyhdl = delete $reqstate->{proxyhdl}) {
 136         &$shutdown_hdl($proxyhdl);
 137     }
 138
 139     my $hdl = delete $reqstate->{hdl};
 140
 141     if (!$hdl) {
 142         syslog('err', "detected empty handle");
 143         return;
 144     }
 145
 146     print "close connection $hdl\n" if $self->{debug};
 147
 148     &$shutdown_hdl($hdl);
 149
 150     $self->{conn_count}--;
 151
 152     print "$$: CLOSE FH" .  $hdl->{fh}->fileno() . " CONN$self->{conn_count}\n" if $self->{debug};
 153 }
 154
 155 sub finish_response {
 156     my ($self, $reqstate) = @_;
 157
 158     cleanup_reqstate($reqstate);
 159
 160     my $hdl = $reqstate->{hdl};
 161     return if !$hdl; # already disconnected
 162
 163     if (!$self->{end_loop} && $reqstate->{keep_alive} > 0) {
 164         # print "KEEPALIVE $reqstate->{keep_alive}\n" if $self->{debug};
 165         $hdl->on_read(sub {
 166             eval { $self->push_request_header($reqstate); };
 167             warn $@ if $@;
 168         });
 169     } else {
 170         $hdl->on_drain (sub {
 171             eval {
 172                 $self->client_do_disconnect($reqstate);
 173             };
 174             warn $@ if $@;
 175         });
 176     }
 177 }
 178
 179 sub response {
 180     my ($self, $reqstate, $resp, $mtime, $nocomp, $delay) = @_;
 181
 182     #print "$$: send response: " . Dumper($resp);
 183
 184     # activate timeout
 185     $reqstate->{hdl}->timeout_reset();
 186     $reqstate->{hdl}->timeout($self->{timeout});
 187
 188     $nocomp = 1 if !$self->{compression};
 189     $nocomp = 1 if !$reqstate->{accept_gzip};
 190
 191     my $code = $resp->code;
 192     my $msg = $resp->message || HTTP::Status::status_message($code);
 193     ($msg) = $msg =~m/^(.*)$/m;
 194     my $content = $resp->content;
 195
 196     if ($code =~ /^(1\d\d|[23]04)$/) {
 197         # make sure content we have no content
 198         $content = "";
 199     }
 200
 201     $reqstate->{keep_alive} = 0 if ($code >= 400) || $self->{end_loop};
 202
 203     $reqstate->{log}->{code} = $code;
 204
 205     my $proto = $reqstate->{proto} ? $reqstate->{proto}->{str} : 'HTTP/1.0';
 206     my $res = "$proto $code $msg\015\012";
 207
 208     my $ctime = time();
 209     my $date = HTTP::Date::time2str($ctime);
 210     $resp->header('Date' => $date);
 211     if ($mtime) {
 212         $resp->header('Last-Modified' => HTTP::Date::time2str($mtime));
 213     } else {
 214         $resp->header('Expires' => $date);
 215         $resp->header('Cache-Control' => "max-age=0");
 216         $resp->header("Pragma", "no-cache");
 217     }
 218
 219     $resp->header('Server' => "pve-api-daemon/3.0");
 220
 221     my $content_length;
 222     if ($content) {
 223
 224         $content_length = length($content);
 225
 226         if (!$nocomp && ($content_length > 1024)) {
 227             my $comp = Compress::Zlib::memGzip($content);
 228             $resp->header('Content-Encoding', 'gzip');
 229             $content = $comp;
 230             $content_length = length($content);
 231         }
 232         $resp->header("Content-Length" => $content_length);
 233         $reqstate->{log}->{content_length} = $content_length;
 234
 235     } else {
 236         $resp->remove_header("Content-Length");
 237     }
 238
 239     if ($reqstate->{keep_alive} > 0) {
 240         $resp->push_header('Connection' => 'Keep-Alive');
 241     } else {
 242         $resp->header('Connection' => 'close');
 243     }
 244
 245     $res .= $resp->headers_as_string("\015\012");
 246     #print "SEND(without content) $res\n" if $self->{debug};
 247
 248     $res .= "\015\012";
 249     $res .= $content if $content;
 250
 251     $self->log_request($reqstate, $reqstate->{request});
 252
 253     if ($delay && $delay > 0) {
 254         my $w; $w = AnyEvent->timer(after => $delay, cb => sub {
 255             undef $w; # delete reference
 256             $reqstate->{hdl}->push_write($res);
 257             $self->finish_response($reqstate);
 258         });
 259     } else {
 260         $reqstate->{hdl}->push_write($res);
 261         $self->finish_response($reqstate);
 262     }
 263 }
 264
 265 sub error {
 266     my ($self, $reqstate, $code, $msg, $hdr, $content) = @_;
 267
 268     eval {
 269         my $resp = HTTP::Response->new($code, $msg, $hdr, $content);
 270         $self->response($reqstate, $resp);
 271     };
 272     warn $@ if $@;
 273 }
 274
 275 my $file_extension_info = {
 276     css   => { ct => 'text/css' },
 277     html  => { ct => 'text/html' },
 278     js    => { ct => 'application/javascript' },
 279     json  => { ct => 'application/json' },
 280     map   => { ct => 'application/json' },
 281     png   => { ct => 'image/png' , nocomp => 1 },
 282     ico   => { ct => 'image/x-icon', nocomp => 1},
 283     gif   => { ct => 'image/gif', nocomp => 1},
 284     svg   => { ct => 'image/svg+xml' },
 285     jar   => { ct => 'application/java-archive', nocomp => 1},
 286     woff  => { ct => 'application/font-woff', nocomp => 1},
 287     woff2 => { ct => 'application/font-woff2', nocomp => 1},
 288     ttf   => { ct => 'application/font-snft', nocomp => 1},
 289     pdf   => { ct => 'application/pdf', nocomp => 1},
 290     epub  => { ct => 'application/epub+zip', nocomp => 1},
 291     mp3   => { ct => 'audio/mpeg', nocomp => 1},
 292     oga   => { ct => 'audio/ogg', nocomp => 1},
 293     tgz   => { ct => 'application/x-compressed-tar', nocomp => 1},
 294 };
 295
 296 sub send_file_start {
 297     my ($self, $reqstate, $download) = @_;
 298
 299     eval {
 300         # print "SEND FILE $filename\n";
 301         # Note: aio_load() this is not really async unless we use IO::AIO!
 302         eval {
 303
 304             my $r = $reqstate->{request};
 305
 306             my $fh;
 307             my $nocomp;
 308             my $mime;
 309
 310             if (ref($download) eq 'HASH') {
 311                 $fh = $download->{fh};
 312                 $mime = $download->{'content-type'};
 313             } else {
 314                 my $filename = $download;
 315                 $fh = IO::File->new($filename, '<') ||
 316                     die "unable to open file '$filename' - $!\n";
 317
 318                 my ($ext) = $filename =~ m/\.([^.]*)$/;
 319                 my $ext_info = $file_extension_info->{$ext};
 320
 321                 die "unable to detect content type" if !$ext_info;
 322                 $mime = $ext_info->{ct};
 323                 $nocomp = $ext_info->{nocomp};
 324             }
 325
 326             my $stat = File::stat::stat($fh) ||
 327                 die "$!\n";
 328
 329             my $mtime = $stat->mtime;
 330
 331             if (my $ifmod = $r->header('if-modified-since')) {
 332                 my $iftime = HTTP::Date::str2time($ifmod);
 333                 if ($mtime <= $iftime) {
 334                     my $resp = HTTP::Response->new(304, "NOT MODIFIED");
 335                     $self->response($reqstate, $resp, $mtime);
 336                     return;
 337                 }
 338             }
 339
 340             my $data;
 341             my $len = sysread($fh, $data,  $stat->size);
 342             die "got short file\n" if !defined($len) || $len != $stat->size;
 343
 344             my $header = HTTP::Headers->new(Content_Type => $mime);
 345             my $resp = HTTP::Response->new(200, "OK", $header, $data);
 346             $self->response($reqstate, $resp, $mtime, $nocomp);
 347         };
 348         if (my $err = $@) {
 349             $self->error($reqstate, 501, $err);
 350         }
 351     };
 352
 353     warn $@ if $@;
 354 }
 355
 356 sub websocket_proxy {
 357     my ($self, $reqstate, $wsaccept, $wsproto, $param) = @_;
 358
 359     eval {
 360         my $remhost;
 361         my $remport;
 362
 363         my $max_payload_size = 128*1024;
 364
 365         my $binary;
 366         if ($wsproto eq 'binary') {
 367             $binary = 1;
 368         } elsif ($wsproto eq 'base64') {
 369             $binary = 0;
 370         } else {
 371             die "websocket_proxy: unsupported protocol '$wsproto'\n";
 372         }
 373
 374         if ($param->{port}) {
 375             $remhost = 'localhost';
 376             $remport = $param->{port};
 377         } elsif ($param->{socket}) {
 378             $remhost = 'unix/';
 379             $remport = $param->{socket};
 380         } else {
 381             die "websocket_proxy: missing port or socket\n";
 382         }
 383
 384         my $encode = sub {
 385             my ($data, $opcode) = @_;
 386
 387             my $string;
 388             my $payload;
 389             if ($binary) {
 390                 $string = $opcode ? $opcode : "\x82"; # binary frame
 391                 $payload = $$data;
 392             } else {
 393                 $string = $opcode ? $opcode : "\x81"; # text frame
 394                 $payload = encode_base64($$data, '');
 395             }
 396
 397             my $payload_len = length($payload);
 398             if ($payload_len <= 125) {
 399                 $string .= pack 'C', $payload_len;
 400             } elsif ($payload_len <= 0xffff) {
 401                 $string .= pack 'C', 126;
 402                 $string .= pack 'n', $payload_len;
 403             } else {
 404                 $string .= pack 'C', 127;
 405                 $string .= pack 'Q>', $payload_len;
 406             }
 407             $string .= $payload;
 408             return $string;
 409         };
 410
 411         tcp_connect $remhost, $remport, sub {
 412             my ($fh) = @_
 413                 or die "connect to '$remhost:$remport' failed: $!";
 414
 415             print "$$: CONNECTed to '$remhost:$remport'\n" if $self->{debug};
 416
 417             $reqstate->{proxyhdl} = AnyEvent::Handle->new(
 418                 fh => $fh,
 419                 rbuf_max => $max_payload_size,
 420                 wbuf_max => $max_payload_size*5,
 421                 timeout => 5,
 422                 on_eof => sub {
 423                     my ($hdl) = @_;
 424                     eval {
 425                         $self->log_aborted_request($reqstate);
 426                         $self->client_do_disconnect($reqstate);
 427                     };
 428                     if (my $err = $@) { syslog('err', $err); }
 429                 },
 430                 on_error => sub {
 431                     my ($hdl, $fatal, $message) = @_;
 432                     eval {
 433                         $self->log_aborted_request($reqstate, $message);
 434                         $self->client_do_disconnect($reqstate);
 435                     };
 436                     if (my $err = $@) { syslog('err', "$err"); }
 437                 });
 438
 439             my $proxyhdlreader = sub {
 440                 my ($hdl) = @_;
 441
 442                 my $len = length($hdl->{rbuf});
 443                 my $data = substr($hdl->{rbuf}, 0, $len > $max_payload_size ? $max_payload_size : $len, '');
 444
 445                 my $string = $encode->(\$data);
 446
 447                 $reqstate->{hdl}->push_write($string) if $reqstate->{hdl};
 448             };
 449
 450             my $hdlreader = sub {
 451                 my ($hdl) = @_;
 452
 453                 while (my $len = length($hdl->{rbuf})) {
 454                     return if $len < 2;
 455
 456                     my $hdr = unpack('C', substr($hdl->{rbuf}, 0, 1));
 457                     my $opcode = $hdr & 0b00001111;
 458                     my $fin = $hdr & 0b10000000;
 459
 460                     die "received fragmented websocket frame\n" if !$fin;
 461
 462                     my $rsv = $hdr & 0b01110000;
 463                     die "received websocket frame with RSV flags\n" if $rsv;
 464
 465                     my $payload_len = unpack 'C', substr($hdl->{rbuf}, 1, 1);
 466
 467                     my $masked = $payload_len & 0b10000000;
 468                     die "received unmasked websocket frame from client\n" if !$masked;
 469
 470                     my $offset = 2;
 471                     $payload_len = $payload_len & 0b01111111;
 472                     if ($payload_len == 126) {
 473                         return if $len < 4;
 474                         $payload_len = unpack('n', substr($hdl->{rbuf}, $offset, 2));
 475                         $offset += 2;
 476                     } elsif ($payload_len == 127) {
 477                         return if $len < 10;
 478                         $payload_len = unpack('Q>', substr($hdl->{rbuf}, $offset, 8));
 479                         $offset += 8;
 480                     }
 481
 482                     die "received too large websocket frame (len = $payload_len)\n"
 483                         if ($payload_len > $max_payload_size) || ($payload_len < 0);
 484
 485                     return if $len < ($offset + 4 + $payload_len);
 486
 487                     my $data = substr($hdl->{rbuf}, 0, $offset + 4 + $payload_len, ''); # now consume data
 488
 489                     my $mask = substr($data, $offset, 4);
 490                     $offset += 4;
 491
 492                     my $payload = substr($data, $offset, $payload_len);
 493
 494                     # NULL-mask might be used over TLS, skip to increase performance
 495                     if ($mask ne pack('N', 0)) {
 496                         # repeat 4 byte mask to payload length + up to 4 byte
 497                         $mask = $mask x (int($payload_len / 4) + 1);
 498                         # truncate mask to payload length
 499                         substr($mask, $payload_len) = "";
 500                         # (un-)apply mask
 501                         $payload ^= $mask;
 502                     }
 503
 504                     $payload = decode_base64($payload) if !$binary;
 505
 506                     if ($opcode == 1 || $opcode == 2) {
 507                         $reqstate->{proxyhdl}->push_write($payload) if $reqstate->{proxyhdl};
 508                     } elsif ($opcode == 8) {
 509                         my $statuscode = unpack ("n", $payload);
 510                         print "websocket received close. status code: '$statuscode'\n" if $self->{debug};
 511                         if ($reqstate->{proxyhdl}) {
 512                             $reqstate->{proxyhdl}->push_shutdown();
 513                         }
 514                         $hdl->push_shutdown();
 515                     } elsif ($opcode == 9) {
 516                         # ping received, schedule pong
 517                         $reqstate->{hdl}->push_write($encode->(\$payload, "\x8A")) if $reqstate->{hdl};
 518                     } elsif ($opcode == 0xA) {
 519                         # pong received, continue
 520                     } else {
 521                         die "received unhandled websocket opcode $opcode\n";
 522                     }
 523                 }
 524             };
 525
 526             my $proto = $reqstate->{proto} ? $reqstate->{proto}->{str} : 'HTTP/1.1';
 527
 528             $reqstate->{proxyhdl}->timeout(0);
 529             $reqstate->{proxyhdl}->on_read($proxyhdlreader);
 530             $reqstate->{hdl}->on_read($hdlreader);
 531
 532             # todo: use stop_read/start_read if write buffer grows to much
 533
 534             my $res = "$proto 101 Switching Protocols\015\012" .
 535                 "Upgrade: websocket\015\012" .
 536                 "Connection: upgrade\015\012" .
 537                 "Sec-WebSocket-Accept: $wsaccept\015\012" .
 538                 "Sec-WebSocket-Protocol: $wsproto\015\012" .
 539                 "\015\012";
 540
 541             print $res if $self->{debug};
 542
 543             $reqstate->{hdl}->push_write($res);
 544
 545             # log early
 546             $reqstate->{log}->{code} = 101;
 547             $self->log_request($reqstate);
 548         };
 549
 550     };
 551     if (my $err = $@) {
 552         warn $err;
 553         $self->log_aborted_request($reqstate, $err);
 554         $self->client_do_disconnect($reqstate);
 555     }
 556 }
 557
 558 sub proxy_request {
 559     my ($self, $reqstate, $clientip, $host, $node, $method, $uri, $auth, $params) = @_;
 560
 561     eval {
 562         my $target;
 563         my $keep_alive = 1;
 564         if ($host eq 'localhost') {
 565             $target = "http://$host:85$uri";
 566             # keep alive for localhost is not worth (connection setup is about 0.2ms)
 567             $keep_alive = 0;
 568         } elsif (Net::IP::ip_is_ipv6($host)) {
 569             $target = "https://[$host]:8006$uri";
 570         } else {
 571             $target = "https://$host:8006$uri";
 572         }
 573
 574         my $headers = {
 575             PVEDisableProxy => 'true',
 576             PVEClientIP => $clientip,
 577         };
 578
 579         $headers->{'cookie'} = PVE::APIServer::Formatter::create_auth_cookie($auth->{ticket}, $self->{cookie_name})
 580             if $auth->{ticket};
 581         $headers->{'Authorization'} = PVE::APIServer::Formatter::create_auth_header($auth->{api_token}, $self->{apitoken_name})
 582             if $auth->{api_token};
 583         $headers->{'CSRFPreventionToken'} = $auth->{token}
 584             if $auth->{token};
 585         $headers->{'Accept-Encoding'} = 'gzip' if ($reqstate->{accept_gzip} && $self->{compression});
 586
 587         if (defined(my $host = $reqstate->{request}->header('Host'))) {
 588             $headers->{Host} = $host;
 589         }
 590
 591         my $content;
 592
 593         if  ($method eq 'POST' || $method eq 'PUT') {
 594             $headers->{'Content-Type'} = 'application/x-www-form-urlencoded';
 595             # use URI object to format application/x-www-form-urlencoded content.
 596             my $url = URI->new('http:');
 597             $url->query_form(%$params);
 598             $content = $url->query;
 599             if (defined($content)) {
 600                 $headers->{'Content-Length'} = length($content);
 601             }
 602         }
 603
 604         my $tls = {
 605             # TLS 1.x only, with certificate pinning
 606             method => 'any',
 607             sslv2 => 0,
 608             sslv3 => 0,
 609             verify => 1,
 610             verify_cb => sub {
 611                 my (undef, undef, undef, $depth, undef, undef, $cert) = @_;
 612                 # we don't care about intermediate or root certificates
 613                 return 1 if $depth != 0;
 614                 # check server certificate against cache of pinned FPs
 615                 return $self->check_cert_fingerprint($cert);
 616             },
 617         };
 618
 619         # load and cache cert fingerprint if first time we proxy to this node
 620         $self->initialize_cert_cache($node);
 621
 622         my $w; $w = http_request(
 623             $method => $target,
 624             headers => $headers,
 625             timeout => 30,
 626             recurse => 0,
 627             proxy => undef, # avoid use of $ENV{HTTP_PROXY}
 628             keepalive => $keep_alive,
 629             body => $content,
 630             tls_ctx => AnyEvent::TLS->new(%{$tls}),
 631             sub {
 632                 my ($body, $hdr) = @_;
 633
 634                 undef $w;
 635
 636                 if (!$reqstate->{hdl}) {
 637                     warn "proxy detected vanished client connection\n";
 638                     return;
 639                 }
 640
 641                 eval {
 642                     my $code = delete $hdr->{Status};
 643                     my $msg = delete $hdr->{Reason};
 644                     delete $hdr->{URL};
 645                     delete $hdr->{HTTPVersion};
 646                     my $header = HTTP::Headers->new(%$hdr);
 647                     if (my $location = $header->header('Location')) {
 648                         $location =~ s|^http://localhost:85||;
 649                         $header->header(Location => $location);
 650                     }
 651                     my $resp = HTTP::Response->new($code, $msg, $header, $body);
 652                     # Note: disable compression, because body is already compressed
 653                     $self->response($reqstate, $resp, undef, 1);
 654                 };
 655                 warn $@ if $@;
 656             });
 657     };
 658     warn $@ if $@;
 659 }
 660
 661 # return arrays as \0 separated strings (like CGI.pm)
 662 # assume data is UTF8 encoded
 663 sub decode_urlencoded {
 664     my ($data) = @_;
 665
 666     my $res = {};
 667
 668     return $res if !$data;
 669
 670     foreach my $kv (split(/[\&\;]/, $data)) {
 671         my ($k, $v) = split(/=/, $kv);
 672         $k =~s/\+/ /g;
 673         $k =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
 674
 675         if (defined($v)) {
 676             $v =~s/\+/ /g;
 677             $v =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
 678
 679             $v = Encode::decode('utf8', $v);
 680
 681             if (defined(my $old = $res->{$k})) {
 682                 $v = "$old\0$v";
 683             }
 684         }
 685
 686         $res->{$k} = $v;
 687     }
 688     return $res;
 689 }
 690
 691 sub extract_params {
 692     my ($r, $method) = @_;
 693
 694     my $params = {};
 695
 696     if ($method eq 'PUT' || $method eq 'POST') {
 697         my $ct;
 698         if (my $ctype = $r->header('Content-Type')) {
 699             $ct = parse_content_type($ctype);
 700         }
 701         if (defined($ct) && $ct eq 'application/json')  {
 702             $params = decode_json($r->content);
 703         } else {
 704             $params = decode_urlencoded($r->content);
 705         }
 706     }
 707
 708     my $query_params = decode_urlencoded($r->url->query());
 709
 710     foreach my $k (keys %{$query_params}) {
 711         $params->{$k} = $query_params->{$k};
 712     }
 713
 714     return $params;
 715 }
 716
 717 sub handle_api2_request {
 718     my ($self, $reqstate, $auth, $method, $path, $upload_state) = @_;
 719
 720     eval {
 721         my $r = $reqstate->{request};
 722
 723         my ($rel_uri, $format) = &$split_abs_uri($path, $self->{base_uri});
 724
 725         my $formatter = PVE::APIServer::Formatter::get_formatter($format, $method, $rel_uri);
 726
 727         if (!defined($formatter)) {
 728             $self->error($reqstate, HTTP_NOT_IMPLEMENTED, "no formatter for uri $rel_uri, $format");
 729             return;
 730         }
 731
 732         #print Dumper($upload_state) if $upload_state;
 733
 734         my $params;
 735
 736         if ($upload_state) {
 737             $params = $upload_state->{params};
 738         } else {
 739             $params = extract_params($r, $method);
 740         }
 741
 742         delete $params->{_dc}; # remove disable cache parameter
 743
 744         my $clientip = $reqstate->{peer_host};
 745
 746         my $res = $self->rest_handler($clientip, $method, $rel_uri, $auth, $params, $format);
 747
 748         # HACK: see Note 1
 749         Net::SSLeay::ERR_clear_error();
 750
 751         AnyEvent->now_update(); # in case somebody called sleep()
 752
 753         my $upgrade = $r->header('upgrade');
 754         $upgrade = lc($upgrade) if $upgrade;
 755
 756         if (my $host = $res->{proxy}) {
 757
 758             if ($self->{trusted_env}) {
 759                 $self->error($reqstate, HTTP_INTERNAL_SERVER_ERROR, "proxy not allowed");
 760                 return;
 761             }
 762
 763             if ($host ne 'localhost' && $r->header('PVEDisableProxy')) {
 764                 $self->error($reqstate, HTTP_INTERNAL_SERVER_ERROR, "proxy loop detected");
 765                 return;
 766             }
 767
 768             $res->{proxy_params}->{tmpfilename} = $reqstate->{tmpfilename} if $upload_state;
 769
 770             $self->proxy_request($reqstate, $clientip, $host, $res->{proxynode}, $method,
 771                                  $r->uri, $auth, $res->{proxy_params});
 772             return;
 773
 774         } elsif ($upgrade && ($method eq 'GET') && ($path =~ m|websocket$|)) {
 775             die "unable to upgrade to protocol '$upgrade'\n" if !$upgrade || ($upgrade ne 'websocket');
 776             my $wsver = $r->header('sec-websocket-version');
 777             die "unsupported websocket-version '$wsver'\n" if !$wsver || ($wsver ne '13');
 778             my $wsproto_str = $r->header('sec-websocket-protocol');
 779             die "missing websocket-protocol header" if !$wsproto_str;
 780             my $wsproto;
 781             foreach my $p (PVE::Tools::split_list($wsproto_str)) {
 782                 $wsproto = $p if !$wsproto && $p eq 'base64';
 783                 $wsproto = $p if $p eq 'binary';
 784             }
 785             die "unsupported websocket-protocol protocol '$wsproto_str'\n" if !$wsproto;
 786             my $wskey = $r->header('sec-websocket-key');
 787             die "missing websocket-key\n" if !$wskey;
 788             # Note: Digest::SHA::sha1_base64 has wrong padding
 789             my $wsaccept = Digest::SHA::sha1_base64("${wskey}258EAFA5-E914-47DA-95CA-C5AB0DC85B11") . "=";
 790             if ($res->{status} == HTTP_OK) {
 791                 $self->websocket_proxy($reqstate, $wsaccept, $wsproto, $res->{data});
 792                 return;
 793             }
 794         }
 795
 796         my $delay = 0;
 797         if ($res->{status} == HTTP_UNAUTHORIZED) {
 798             # always delay unauthorized calls by 3 seconds
 799             $delay = 3 - tv_interval($reqstate->{starttime});
 800             $delay = 0 if $delay < 0;
 801         }
 802
 803         if (defined(my $download = $res->{download})) {
 804             send_file_start($self, $reqstate, $download);
 805             return;
 806         }
 807
 808         my ($raw, $ct, $nocomp) = $formatter->($res, $res->{data}, $params, $path,
 809                                                $auth, $self->{formatter_config});
 810
 811         my $resp;
 812         if (ref($raw) && (ref($raw) eq 'HTTP::Response')) {
 813             $resp = $raw;
 814         } else {
 815             $resp = HTTP::Response->new($res->{status}, $res->{message});
 816             $resp->header("Content-Type" => $ct);
 817             $resp->content($raw);
 818         }
 819         $self->response($reqstate, $resp, undef, $nocomp, $delay);
 820     };
 821     if (my $err = $@) {
 822         $self->error($reqstate, 501, $err);
 823     }
 824 }
 825
 826 sub handle_spice_proxy_request {
 827     my ($self, $reqstate, $connect_str, $vmid, $node, $spiceport) = @_;
 828
 829     eval {
 830
 831         my ($minport, $maxport) = PVE::Tools::spice_port_range();
 832         if ($spiceport < $minport || $spiceport > $maxport) {
 833             die "SPICE Port $spiceport is not in allowed range ($minport, $maxport)\n";
 834         }
 835
 836         my $clientip = $reqstate->{peer_host};
 837         my $r = $reqstate->{request};
 838
 839         my $remip;
 840
 841         if ($node ne 'localhost' && PVE::INotify::nodename() !~ m/^$node$/i) {
 842             $remip = $self->remote_node_ip($node);
 843             print "REMOTE CONNECT $vmid, $remip, $connect_str\n" if $self->{debug};
 844         } else {
 845             print "$$: CONNECT $vmid, $node, $spiceport\n" if $self->{debug};
 846         }
 847
 848         if ($remip && $r->header('PVEDisableProxy')) {
 849             $self->error($reqstate, HTTP_INTERNAL_SERVER_ERROR, "proxy loop detected");
 850             return;
 851         }
 852
 853         $reqstate->{hdl}->timeout(0);
 854         $reqstate->{hdl}->wbuf_max(64*10*1024);
 855
 856         my $remhost = $remip ? $remip : "localhost";
 857         my $remport = $remip ? 3128 : $spiceport;
 858
 859         tcp_connect $remhost, $remport, sub {
 860             my ($fh) = @_
 861                 or die "connect to '$remhost:$remport' failed: $!";
 862
 863             print "$$: CONNECTed to '$remhost:$remport'\n" if $self->{debug};
 864             $reqstate->{proxyhdl} = AnyEvent::Handle->new(
 865                 fh => $fh,
 866                 rbuf_max => 64*1024,
 867                 wbuf_max => 64*10*1024,
 868                 timeout => 5,
 869                 on_eof => sub {
 870                     my ($hdl) = @_;
 871                     eval {
 872                         $self->log_aborted_request($reqstate);
 873                         $self->client_do_disconnect($reqstate);
 874                     };
 875                     if (my $err = $@) { syslog('err', $err); }
 876                 },
 877                 on_error => sub {
 878                     my ($hdl, $fatal, $message) = @_;
 879                     eval {
 880                         $self->log_aborted_request($reqstate, $message);
 881                         $self->client_do_disconnect($reqstate);
 882                     };
 883                     if (my $err = $@) { syslog('err', "$err"); }
 884                 });
 885
 886
 887             my $proxyhdlreader = sub {
 888                 my ($hdl) = @_;
 889
 890                 my $len = length($hdl->{rbuf});
 891                 my $data = substr($hdl->{rbuf}, 0, $len, '');
 892
 893                 #print "READ1 $len\n";
 894                 $reqstate->{hdl}->push_write($data) if $reqstate->{hdl};
 895             };
 896
 897             my $hdlreader = sub {
 898                 my ($hdl) = @_;
 899
 900                 my $len = length($hdl->{rbuf});
 901                 my $data = substr($hdl->{rbuf}, 0, $len, '');
 902
 903                 #print "READ0 $len\n";
 904                 $reqstate->{proxyhdl}->push_write($data) if $reqstate->{proxyhdl};
 905             };
 906
 907             my $proto = $reqstate->{proto} ? $reqstate->{proto}->{str} : 'HTTP/1.0';
 908
 909             my $startproxy = sub {
 910                 $reqstate->{proxyhdl}->timeout(0);
 911                 $reqstate->{proxyhdl}->on_read($proxyhdlreader);
 912                 $reqstate->{hdl}->on_read($hdlreader);
 913
 914                 # todo: use stop_read/start_read if write buffer grows to much
 915
 916                 # a response must be followed by an empty line
 917                 my $res = "$proto 200 OK\015\012\015\012";
 918                 $reqstate->{hdl}->push_write($res);
 919
 920                 # log early
 921                 $reqstate->{log}->{code} = 200;
 922                 $self->log_request($reqstate);
 923             };
 924
 925             if ($remip) {
 926                 my $header = "CONNECT ${connect_str} $proto\015\012" .
 927                     "Host: ${connect_str}\015\012" .
 928                     "Proxy-Connection: keep-alive\015\012" .
 929                     "User-Agent: spiceproxy\015\012" .
 930                     "PVEDisableProxy: true\015\012" .
 931                     "PVEClientIP: $clientip\015\012" .
 932                     "\015\012";
 933
 934                 $reqstate->{proxyhdl}->push_write($header);
 935                 $reqstate->{proxyhdl}->push_read(line => sub {
 936                     my ($hdl, $line) = @_;
 937
 938                     if ($line =~ m!^$proto 200 OK$!) {
 939                         # read the empty line after the 200 OK
 940                         $reqstate->{proxyhdl}->unshift_read(line => sub{
 941                             &$startproxy();
 942                         });
 943                     } else {
 944                         $reqstate->{hdl}->push_write($line);
 945                         $self->client_do_disconnect($reqstate);
 946                     }
 947                 });
 948             } else {
 949                 &$startproxy();
 950             }
 951
 952         };
 953     };
 954     if (my $err = $@) {
 955         warn $err;
 956         $self->log_aborted_request($reqstate, $err);
 957         $self->client_do_disconnect($reqstate);
 958     }
 959 }
 960
 961 sub handle_request {
 962     my ($self, $reqstate, $auth, $method, $path) = @_;
 963
 964     my $base_uri = $self->{base_uri};
 965
 966     eval {
 967         my $r = $reqstate->{request};
 968
 969         # disable timeout on handle (we already have all data we need)
 970         # we re-enable timeout in response()
 971         $reqstate->{hdl}->timeout(0);
 972
 973         if ($path =~ m/^\Q$base_uri\E/) {
 974             $self->handle_api2_request($reqstate, $auth, $method, $path);
 975             return;
 976         }
 977
 978         if ($self->{pages} && ($method eq 'GET') && (my $handler = $self->{pages}->{$path})) {
 979             if (ref($handler) eq 'CODE') {
 980                 my $params = decode_urlencoded($r->url->query());
 981                 my ($resp, $userid) = &$handler($self, $reqstate->{request}, $params);
 982                 # HACK: see Note 1
 983                 Net::SSLeay::ERR_clear_error();
 984                 $self->response($reqstate, $resp);
 985             } elsif (ref($handler) eq 'HASH') {
 986                 if (my $filename = $handler->{file}) {
 987                     my $fh = IO::File->new($filename) ||
 988                         die "unable to open file '$filename' - $!\n";
 989                     send_file_start($self, $reqstate, $filename);
 990                 } else {
 991                     die "internal error - no handler";
 992                 }
 993             } else {
 994                 die "internal error - no handler";
 995             }
 996             return;
 997         }
 998
 999         if ($self->{dirs} && ($method eq 'GET')) {
1000             # we only allow simple names
1001             if ($path =~ m!^(/\S+/)([a-zA-Z0-9\-\_\.]+)$!) {
1002                 my ($subdir, $file) = ($1, $2);
1003                 if (my $dir = $self->{dirs}->{$subdir}) {
1004                     my $filename = "$dir$file";
1005                     my $fh = IO::File->new($filename) ||
1006                         die "unable to open file '$filename' - $!\n";
1007                     send_file_start($self, $reqstate, $filename);
1008                     return;
1009                 }
1010             }
1011         }
1012
1013         die "no such file '$path'\n";
1014     };
1015     if (my $err = $@) {
1016         $self->error($reqstate, 501, $err);
1017     }
1018 }
1019
1020 sub file_upload_multipart {
1021     my ($self, $reqstate, $auth, $method, $path, $rstate) = @_;
1022
1023     eval {
1024         my $boundary = $rstate->{boundary};
1025         my $hdl = $reqstate->{hdl};
1026
1027         my $startlen = length($hdl->{rbuf});
1028
1029         if ($rstate->{phase} == 0) { # skip everything until start
1030             if ($hdl->{rbuf} =~ s/^.*?--\Q$boundary\E  \015?\012
1031                        ((?:[^\015]+\015\012)* ) \015?\012//xs) {
1032                 my $header = $1;
1033                 my ($ct, $disp, $name, $filename);
1034                 foreach my $line (split(/\015?\012/, $header)) {
1035                     # assume we have single line headers
1036                     if ($line =~ m/^Content-Type\s*:\s*(.*)/i) {
1037                         $ct = parse_content_type($1);
1038                     } elsif ($line =~ m/^Content-Disposition\s*:\s*(.*)/i) {
1039                         ($disp, $name, $filename) = parse_content_disposition($1);
1040                     }
1041                 }
1042
1043                 if (!($disp && $disp eq 'form-data' && $name)) {
1044                     syslog('err', "wrong content disposition in multipart - abort upload");
1045                     $rstate->{phase} = -1;
1046                 } else {
1047
1048                     $rstate->{fieldname} = $name;
1049
1050                     if ($filename) {
1051                         if ($name eq 'filename') {
1052                             # found file upload data
1053                             $rstate->{phase} = 1;
1054                             $rstate->{filename} = $filename;
1055                         } else {
1056                             syslog('err', "wrong field name for file upload - abort upload");
1057                             $rstate->{phase} = -1;
1058                         }
1059                     } else {
1060                         # found form data for field $name
1061                         $rstate->{phase} = 2;
1062                     }
1063                 }
1064             } else {
1065                 my $len = length($hdl->{rbuf});
1066                 substr($hdl->{rbuf}, 0, $len - $rstate->{maxheader}, '')
1067                     if $len > $rstate->{maxheader}; # skip garbage
1068             }
1069         } elsif ($rstate->{phase} == 1) { # inside file - dump until end marker
1070             if ($hdl->{rbuf} =~ s/^(.*?)\015?\012(--\Q$boundary\E(--)? \015?\012(.*))$/$2/xs) {
1071                 my ($rest, $eof) = ($1, $3);
1072                 my $len = length($rest);
1073                 die "write to temporary file failed - $!"
1074                     if syswrite($rstate->{outfh}, $rest) != $len;
1075                 $rstate->{ctx}->add($rest);
1076                 $rstate->{params}->{filename} = $rstate->{filename};
1077                 $rstate->{md5sum} = $rstate->{ctx}->hexdigest;
1078                 $rstate->{bytes} += $len;
1079                 $rstate->{phase} =  $eof ? 100 : 0;
1080             } else {
1081                 my $len = length($hdl->{rbuf});
1082                 my $wlen = $len - $rstate->{boundlen};
1083                 if ($wlen > 0) {
1084                     my $data = substr($hdl->{rbuf}, 0, $wlen, '');
1085                     die "write to temporary file failed - $!"
1086                         if syswrite($rstate->{outfh}, $data) != $wlen;
1087                     $rstate->{bytes} += $wlen;
1088                     $rstate->{ctx}->add($data);
1089                 }
1090             }
1091         } elsif ($rstate->{phase} == 2) { # inside normal field
1092
1093             if ($hdl->{rbuf} =~ s/^(.*?)\015?\012(--\Q$boundary\E(--)? \015?\012(.*))$/$2/xs) {
1094                 my ($rest, $eof) = ($1, $3);
1095                 my $len = length($rest);
1096                 $rstate->{post_size} += $len;
1097                 if ($rstate->{post_size} < $limit_max_post) {
1098                     $rstate->{params}->{$rstate->{fieldname}} = $rest;
1099                     $rstate->{phase} = $eof ? 100 : 0;
1100                 } else {
1101                     syslog('err', "form data to large - abort upload");
1102                     $rstate->{phase} = -1; # skip
1103                 }
1104             }
1105         } else { # skip
1106             my $len = length($hdl->{rbuf});
1107             substr($hdl->{rbuf}, 0, $len, ''); # empty rbuf
1108         }
1109
1110         $rstate->{read} += ($startlen - length($hdl->{rbuf}));
1111
1112         if (!$rstate->{done} && ($rstate->{read} + length($hdl->{rbuf})) >= $rstate->{size}) {
1113             $rstate->{done} = 1; # make sure we dont get called twice
1114             if ($rstate->{phase} < 0 || !$rstate->{md5sum}) {
1115                 die "upload failed\n";
1116             } else {
1117                 my $elapsed = tv_interval($rstate->{starttime});
1118
1119                 my $rate = int($rstate->{bytes}/($elapsed*1024*1024));
1120                 syslog('info', "multipart upload complete " .
1121                        "(size: %d time: %ds rate: %.2fMiB/s md5sum: $rstate->{md5sum})",
1122                        $rstate->{bytes}, $elapsed, $rate);
1123                 $self->handle_api2_request($reqstate, $auth, $method, $path, $rstate);
1124             }
1125         }
1126     };
1127     if (my $err = $@) {
1128         syslog('err', $err);
1129         $self->error($reqstate, 501, $err);
1130     }
1131 }
1132
1133 sub parse_content_type {
1134     my ($ctype) = @_;
1135
1136     my ($ct, @params) = split(/\s*[;,]\s*/o, $ctype);
1137
1138     foreach my $v (@params) {
1139         if ($v =~ m/^\s*boundary\s*=\s*(\S+?)\s*$/o) {
1140             return wantarray ? ($ct, $1) : $ct;
1141         }
1142     }
1143
1144     return  wantarray ? ($ct) : $ct;
1145 }
1146
1147 sub parse_content_disposition {
1148     my ($line) = @_;
1149
1150     my ($disp, @params) = split(/\s*[;,]\s*/o, $line);
1151     my $name;
1152     my $filename;
1153
1154     foreach my $v (@params) {
1155         if ($v =~ m/^\s*name\s*=\s*(\S+?)\s*$/o) {
1156             $name = $1;
1157             $name =~ s/^"(.*)"$/$1/;
1158         } elsif ($v =~ m/^\s*filename\s*=\s*(.+?)\s*$/o) {
1159             $filename = $1;
1160             $filename =~ s/^"(.*)"$/$1/;
1161         }
1162     }
1163
1164     return  wantarray ? ($disp, $name, $filename) : $disp;
1165 }
1166
1167 my $tmpfile_seq_no = 0;
1168
1169 sub get_upload_filename {
1170     # choose unpredictable tmpfile name
1171
1172     $tmpfile_seq_no++;
1173     return "/var/tmp/pveupload-" . Digest::MD5::md5_hex($tmpfile_seq_no . time() . $$);
1174 }
1175
1176 sub unshift_read_header {
1177     my ($self, $reqstate, $state) = @_;
1178
1179     $state = { size => 0, count => 0 } if !$state;
1180
1181     $reqstate->{hdl}->unshift_read(line => sub {
1182         my ($hdl, $line) = @_;
1183
1184         eval {
1185             # print "$$: got header: $line\n" if $self->{debug};
1186
1187             die "too many http header lines (> $limit_max_headers)\n" if ++$state->{count} >= $limit_max_headers;
1188             die "http header too large\n" if ($state->{size} += length($line)) >= $limit_max_header_size;
1189
1190             my $r = $reqstate->{request};
1191             if ($line eq '') {
1192
1193                 my $path = uri_unescape($r->uri->path());
1194                 my $method = $r->method();
1195
1196                 $r->push_header($state->{key}, $state->{val})
1197                     if $state->{key};
1198
1199                 if (!$known_methods->{$method}) {
1200                     my $resp = HTTP::Response->new(HTTP_NOT_IMPLEMENTED, "method '$method' not available");
1201                     $self->response($reqstate, $resp);
1202                     return;
1203                 }
1204
1205                 my $conn = $r->header('Connection');
1206                 my $accept_enc = $r->header('Accept-Encoding');
1207                 $reqstate->{accept_gzip} = ($accept_enc && $accept_enc =~ m/gzip/) ? 1 : 0;
1208
1209                 if ($conn) {
1210                     $reqstate->{keep_alive} = 0 if $conn =~ m/close/oi;
1211                 } else {
1212                     if ($reqstate->{proto}->{ver} < 1001) {
1213                         $reqstate->{keep_alive} = 0;
1214                     }
1215                 }
1216
1217                 my $te  = $r->header('Transfer-Encoding');
1218                 if ($te && lc($te) eq 'chunked') {
1219                     # Handle chunked transfer encoding
1220                     $self->error($reqstate, 501, "chunked transfer encoding not supported");
1221                     return;
1222                 } elsif ($te) {
1223                     $self->error($reqstate, 501, "Unknown transfer encoding '$te'");
1224                     return;
1225                 }
1226
1227                 my $pveclientip = $r->header('PVEClientIP');
1228                 my $base_uri = $self->{base_uri};
1229
1230                 # fixme: how can we make PVEClientIP header trusted?
1231                 if ($self->{trusted_env} && $pveclientip) {
1232                     $reqstate->{peer_host} = $pveclientip;
1233                 } else {
1234                     $r->header('PVEClientIP', $reqstate->{peer_host});
1235                 }
1236
1237                 my $len = $r->header('Content-Length');
1238
1239                 my $host_header = $r->header('Host');
1240                 if (my $rpcenv = $self->{rpcenv}) {
1241                     $rpcenv->set_request_host($host_header);
1242                 }
1243
1244                 # header processing complete - authenticate now
1245
1246                 my $auth = {};
1247                 if ($self->{spiceproxy}) {
1248                     my $connect_str = $host_header;
1249                     my ($vmid, $node, $port) = $self->verify_spice_connect_url($connect_str);
1250                     if (!(defined($vmid) && $node && $port)) {
1251                         $self->error($reqstate, HTTP_UNAUTHORIZED, "invalid ticket");
1252                         return;
1253                     }
1254                     $self->handle_spice_proxy_request($reqstate, $connect_str, $vmid, $node, $port);
1255                     return;
1256                 } elsif ($path =~ m/^\Q$base_uri\E/) {
1257                     my $token = $r->header('CSRFPreventionToken');
1258                     my $cookie = $r->header('Cookie');
1259                     my $auth_header = $r->header('Authorization');
1260
1261                     # prefer actual cookie
1262                     my $ticket = PVE::APIServer::Formatter::extract_auth_value($cookie, $self->{cookie_name});
1263
1264                     # fallback to cookie in 'Authorization' header
1265                     $ticket = PVE::APIServer::Formatter::extract_auth_value($auth_header, $self->{cookie_name})
1266                         if !$ticket;
1267
1268                     # finally, fallback to API token if no ticket has been provided so far
1269                     my $api_token;
1270                     $api_token = PVE::APIServer::Formatter::extract_auth_value($auth_header, $self->{apitoken_name})
1271                         if !$ticket;
1272
1273                     my ($rel_uri, $format) = &$split_abs_uri($path, $self->{base_uri});
1274                     if (!$format) {
1275                         $self->error($reqstate, HTTP_NOT_IMPLEMENTED, "no such uri");
1276                         return;
1277                     }
1278
1279                     eval {
1280                         $auth = $self->auth_handler($method, $rel_uri, $ticket, $token, $api_token,
1281                                                     $reqstate->{peer_host});
1282                     };
1283                     if (my $err = $@) {
1284                         # HACK: see Note 1
1285                         Net::SSLeay::ERR_clear_error();
1286                         # always delay unauthorized calls by 3 seconds
1287                         my $delay = 3;
1288
1289                         if (ref($err) eq "PVE::Exception") {
1290
1291                             $err->{code} ||= HTTP_INTERNAL_SERVER_ERROR,
1292                             my $resp = HTTP::Response->new($err->{code}, $err->{msg});
1293                             $self->response($reqstate, $resp, undef, 0, $delay);
1294
1295                         } elsif (my $formatter = PVE::APIServer::Formatter::get_login_formatter($format)) {
1296                             my ($raw, $ct, $nocomp) =
1297                                 $formatter->($path, $auth, $self->{formatter_config});
1298                             my $resp;
1299                             if (ref($raw) && (ref($raw) eq 'HTTP::Response')) {
1300                                 $resp = $raw;
1301                             } else {
1302                                 $resp = HTTP::Response->new(HTTP_UNAUTHORIZED, "Login Required");
1303                                 $resp->header("Content-Type" => $ct);
1304                                 $resp->content($raw);
1305                             }
1306                             $self->response($reqstate, $resp, undef, $nocomp, $delay);
1307                         } else {
1308                             my $resp = HTTP::Response->new(HTTP_UNAUTHORIZED, $err);
1309                             $self->response($reqstate, $resp, undef, 0, $delay);
1310                         }
1311                         return;
1312                     }
1313                 }
1314
1315                 $reqstate->{log}->{userid} = $auth->{userid};
1316
1317                 if ($len) {
1318
1319                     if (!($method eq 'PUT' || $method eq 'POST')) {
1320                         $self->error($reqstate, 501, "Unexpected content for method '$method'");
1321                         return;
1322                     }
1323
1324                     my $ctype = $r->header('Content-Type');
1325                     my ($ct, $boundary);
1326                     ($ct, $boundary)= parse_content_type($ctype) if $ctype;
1327
1328                     if ($auth->{isUpload} && !$self->{trusted_env}) {
1329                         die "upload 'Content-Type '$ctype' not implemented\n"
1330                             if !($boundary && $ct && ($ct eq 'multipart/form-data'));
1331
1332                         die "upload without content length header not supported" if !$len;
1333
1334                         die "upload without content length header not supported" if !$len;
1335
1336                         print "start upload $path $ct $boundary\n" if $self->{debug};
1337
1338                         my $tmpfilename = get_upload_filename();
1339                         my $outfh = IO::File->new($tmpfilename, O_RDWR|O_CREAT|O_EXCL, 0600) ||
1340                             die "unable to create temporary upload file '$tmpfilename'";
1341
1342                         $reqstate->{keep_alive} = 0;
1343
1344                         my $boundlen = length($boundary) + 8; # \015?\012--$boundary--\015?\012
1345
1346                         my $state = {
1347                             size => $len,
1348                             boundary => $boundary,
1349                             ctx => Digest::MD5->new,
1350                             boundlen =>  $boundlen,
1351                             maxheader => 2048 + $boundlen, # should be large enough
1352                             params => decode_urlencoded($r->url->query()),
1353                             phase => 0,
1354                             read => 0,
1355                             post_size => 0,
1356                             starttime => [gettimeofday],
1357                             outfh => $outfh,
1358                         };
1359                         $reqstate->{tmpfilename} = $tmpfilename;
1360                         $reqstate->{hdl}->on_read(sub { $self->file_upload_multipart($reqstate, $auth, $method, $path, $state); });
1361                         return;
1362                     }
1363
1364                     if ($len > $limit_max_post) {
1365                         $self->error($reqstate, 501, "for data too large");
1366                         return;
1367                     }
1368
1369                     if (!$ct || $ct eq 'application/x-www-form-urlencoded' || $ct eq 'application/json') {
1370                         $reqstate->{hdl}->unshift_read(chunk => $len, sub {
1371                             my ($hdl, $data) = @_;
1372                             $r->content($data);
1373                             $self->handle_request($reqstate, $auth, $method, $path);
1374                         });
1375                     } else {
1376                         $self->error($reqstate, 506, "upload 'Content-Type '$ctype' not implemented");
1377                     }
1378                 } else {
1379                     $self->handle_request($reqstate, $auth, $method, $path);
1380                 }
1381             } elsif ($line =~ /^([^:\s]+)\s*:\s*(.*)/) {
1382                 $r->push_header($state->{key}, $state->{val}) if $state->{key};
1383                 ($state->{key}, $state->{val}) = ($1, $2);
1384                 $self->unshift_read_header($reqstate, $state);
1385             } elsif ($line =~ /^\s+(.*)/) {
1386                 $state->{val} .= " $1";
1387                 $self->unshift_read_header($reqstate, $state);
1388             } else {
1389                 $self->error($reqstate, 506, "unable to parse request header");
1390             }
1391         };
1392         warn $@ if $@;
1393     });
1394 };
1395
1396 sub push_request_header {
1397     my ($self, $reqstate) = @_;
1398
1399     eval {
1400         $reqstate->{hdl}->push_read(line => sub {
1401             my ($hdl, $line) = @_;
1402
1403             eval {
1404                 # print "got request header: $line\n" if $self->{debug};
1405
1406                 $reqstate->{keep_alive}--;
1407
1408                 if ($line =~ /(\S+)\040(\S+)\040HTTP\/(\d+)\.(\d+)/o) {
1409                     my ($method, $url, $maj, $min) = ($1, $2, $3, $4);
1410
1411                     if ($maj != 1) {
1412                         $self->error($reqstate, 506, "http protocol version $maj.$min not supported");
1413                         return;
1414                     }
1415
1416                     $self->{request_count}++; # only count valid request headers
1417                     if ($self->{request_count} >= $self->{max_requests}) {
1418                         $self->{end_loop} = 1;
1419                     }
1420                     $reqstate->{log} = { requestline => $line };
1421                     $reqstate->{proto}->{str} = "HTTP/$maj.$min";
1422                     $reqstate->{proto}->{maj} = $maj;
1423                     $reqstate->{proto}->{min} = $min;
1424                     $reqstate->{proto}->{ver} = $maj*1000+$min;
1425                     $reqstate->{request} = HTTP::Request->new($method, $url);
1426                     $reqstate->{starttime} = [gettimeofday],
1427
1428                     $self->unshift_read_header($reqstate);
1429                 } elsif ($line eq '') {
1430                     # ignore empty lines before requests (browser bugs?)
1431                     $self->push_request_header($reqstate);
1432                 } else {
1433                     $self->error($reqstate, 400, 'bad request');
1434                 }
1435             };
1436             warn $@ if $@;
1437         });
1438     };
1439     warn $@ if $@;
1440 }
1441
1442 sub accept {
1443     my ($self) = @_;
1444
1445     my $clientfh;
1446
1447     return if $self->{end_loop};
1448
1449     # we need to m make sure that only one process calls accept
1450     while (!flock($self->{lockfh}, Fcntl::LOCK_EX())) {
1451         next if $! == EINTR;
1452         die "could not get lock on file '$self->{lockfile}' -  $!\n";
1453     }
1454
1455     my $again = 0;
1456     my $errmsg;
1457     eval {
1458         while (!$self->{end_loop} &&
1459                !defined($clientfh = $self->{socket}->accept()) &&
1460                ($! == EINTR)) {};
1461
1462         if ($self->{end_loop}) {
1463             $again = 0;
1464         } else {
1465             $again = ($! == EAGAIN || $! == WSAEWOULDBLOCK);
1466             if (!defined($clientfh)) {
1467                 $errmsg = "failed to accept connection: $!\n";
1468             }
1469         }
1470     };
1471     warn $@ if $@;
1472
1473     flock($self->{lockfh}, Fcntl::LOCK_UN());
1474
1475     if (!defined($clientfh)) {
1476         return if $again;
1477         die $errmsg if $errmsg;
1478     }
1479
1480     fh_nonblocking $clientfh, 1;
1481
1482     $self->{conn_count}++;
1483
1484     return $clientfh;
1485 }
1486
1487 sub wait_end_loop {
1488     my ($self) = @_;
1489
1490     $self->{end_loop} = 1;
1491
1492     undef $self->{socket_watch};
1493
1494     $0 = "$0 (shutdown)" if $0 !~ m/\(shutdown\)$/;
1495
1496     if ($self->{conn_count} <= 0) {
1497         $self->{end_cond}->send(1);
1498         return;
1499     }
1500
1501     # fork and exit, so that parent starts a new worker
1502     if (fork()) {
1503         exit(0);
1504     }
1505
1506     # else we need to wait until all open connections gets closed
1507     my $w; $w = AnyEvent->timer (after => 1, interval => 1, cb => sub {
1508         eval {
1509             # todo: test for active connections instead (we can abort idle connections)
1510             if ($self->{conn_count} <= 0) {
1511                 undef $w;
1512                 $self->{end_cond}->send(1);
1513             }
1514         };
1515         warn $@ if $@;
1516     });
1517 }
1518
1519
1520 sub check_host_access {
1521     my ($self, $clientip) = @_;
1522
1523     my $cip = Net::IP->new($clientip);
1524
1525     my $match_allow = 0;
1526     my $match_deny = 0;
1527
1528     if ($self->{allow_from}) {
1529         foreach my $t (@{$self->{allow_from}}) {
1530             if ($t->overlaps($cip)) {
1531                 $match_allow = 1;
1532                 last;
1533             }
1534         }
1535     }
1536
1537     if ($self->{deny_from}) {
1538         foreach my $t (@{$self->{deny_from}}) {
1539             if ($t->overlaps($cip)) {
1540                 $match_deny = 1;
1541                 last;
1542             }
1543         }
1544     }
1545
1546     if ($match_allow == $match_deny) {
1547         # match both allow and deny, or no match
1548         return $self->{policy} && $self->{policy} eq 'allow' ? 1 : 0;
1549     }
1550
1551     return $match_allow;
1552 }
1553
1554 sub accept_connections {
1555     my ($self) = @_;
1556
1557     eval {
1558
1559         while (my $clientfh = $self->accept()) {
1560
1561             my $reqstate = { keep_alive => $self->{keep_alive} };
1562
1563             # stop keep-alive when there are many open connections
1564             if ($self->{conn_count} >= $self->{max_conn_soft_limit}) {
1565                 $reqstate->{keep_alive} = 0;
1566             }
1567
1568             if (my $sin = getpeername($clientfh)) {
1569                 my ($pfamily, $pport, $phost) = PVE::Tools::unpack_sockaddr_in46($sin);
1570                 ($reqstate->{peer_port}, $reqstate->{peer_host}) = ($pport,  Socket::inet_ntop($pfamily, $phost));
1571             }
1572
1573             if (!$self->{trusted_env} && !$self->check_host_access($reqstate->{peer_host})) {
1574                 print "$$: ABORT request from $reqstate->{peer_host} - access denied\n" if $self->{debug};
1575                 $reqstate->{log}->{code} = 403;
1576                 $self->log_request($reqstate);
1577                 next;
1578             }
1579
1580             $reqstate->{hdl} = AnyEvent::Handle->new(
1581                 fh => $clientfh,
1582                 rbuf_max => 64*1024,
1583                 timeout => $self->{timeout},
1584                 linger => 0, # avoid problems with ssh - really needed ?
1585                 on_eof   => sub {
1586                     my ($hdl) = @_;
1587                     eval {
1588                         $self->log_aborted_request($reqstate);
1589                         $self->client_do_disconnect($reqstate);
1590                     };
1591                     if (my $err = $@) { syslog('err', $err); }
1592                 },
1593                 on_error => sub {
1594                     my ($hdl, $fatal, $message) = @_;
1595                     eval {
1596                         $self->log_aborted_request($reqstate, $message);
1597                         $self->client_do_disconnect($reqstate);
1598                     };
1599                     if (my $err = $@) { syslog('err', "$err"); }
1600                 },
1601                 ($self->{tls_ctx} ? (tls => "accept", tls_ctx => $self->{tls_ctx}) : ()));
1602
1603             print "$$: ACCEPT FH" .  $clientfh->fileno() . " CONN$self->{conn_count}\n" if $self->{debug};
1604
1605             $self->push_request_header($reqstate);
1606         }
1607     };
1608
1609     if (my $err = $@) {
1610         syslog('err', $err);
1611         $self->{end_loop} = 1;
1612     }
1613
1614     $self->wait_end_loop() if $self->{end_loop};
1615 }
1616
1617 # Note: We can't open log file in non-blocking mode and use AnyEvent::Handle,
1618 # because we write from multiple processes, and that would arbitrarily mix output
1619 # of all processes.
1620 sub open_access_log {
1621     my ($self, $filename) = @_;
1622
1623     my $old_mask = umask(0137);;
1624     my $logfh = IO::File->new($filename, ">>") ||
1625         die "unable to open log file '$filename' - $!\n";
1626     umask($old_mask);
1627
1628     $logfh->autoflush(1);
1629
1630     $self->{logfh} = $logfh;
1631 }
1632
1633 sub write_log {
1634     my ($self, $data) = @_;
1635
1636     return if !defined($self->{logfh}) || !$data;
1637
1638     my $res = $self->{logfh}->print($data);
1639
1640     if (!$res) {
1641         delete $self->{logfh};
1642         syslog('err', "error writing access log");
1643         $self->{end_loop} = 1; # terminate asap
1644     }
1645 }
1646
1647 sub atfork_handler {
1648     my ($self) = @_;
1649
1650     eval {
1651         # something else do to ?
1652         close($self->{socket});
1653     };
1654     warn $@ if $@;
1655 }
1656
1657 sub run {
1658     my ($self) = @_;
1659
1660     $self->{end_cond}->recv;
1661 }
1662
1663 sub new {
1664     my ($this, %args) = @_;
1665
1666     my $class = ref($this) || $this;
1667
1668     foreach my $req (qw(socket lockfh lockfile)) {
1669         die "misssing required argument '$req'" if !defined($args{$req});
1670     }
1671
1672     my $self = bless { %args }, $class;
1673
1674     $self->{cookie_name} //= 'PVEAuthCookie';
1675     $self->{apitoken_name} //= 'PVEAPIToken';
1676     $self->{base_uri} //= "/api2";
1677     $self->{dirs} //= {};
1678     $self->{title} //= 'API Inspector';
1679     $self->{compression} //= 1;
1680
1681     # formatter_config: we pass some configuration values to the Formatter
1682     $self->{formatter_config} = {};
1683     foreach my $p (qw(apitoken_name cookie_name base_uri title)) {
1684         $self->{formatter_config}->{$p} = $self->{$p};
1685     }
1686     $self->{formatter_config}->{csrfgen_func} =
1687         $self->can('generate_csrf_prevention_token');
1688
1689     # add default dirs which includes jquery and bootstrap
1690     my $jsbase = '/usr/share/javascript';
1691     add_dirs($self->{dirs}, '/js/' => "$jsbase/");
1692     # libjs-bootstrap uses symlinks for this, which we do not want to allow..
1693     my $glyphicons = '/usr/share/fonts/truetype/glyphicons/';
1694     add_dirs($self->{dirs}, '/js/bootstrap/fonts/' => "$glyphicons");
1695
1696     # init inotify
1697     PVE::INotify::inotify_init();
1698
1699     fh_nonblocking($self->{socket}, 1);
1700
1701     $self->{end_loop} = 0;
1702     $self->{conn_count} = 0;
1703     $self->{request_count} = 0;
1704     $self->{timeout} = 5 if !$self->{timeout};
1705     $self->{keep_alive} = 0 if !defined($self->{keep_alive});
1706     $self->{max_conn} = 800 if !$self->{max_conn};
1707     $self->{max_requests} = 8000 if !$self->{max_requests};
1708
1709     $self->{policy} = 'allow' if !$self->{policy};
1710
1711     $self->{end_cond} = AnyEvent->condvar;
1712
1713     if ($self->{ssl}) {
1714         my $ssl_defaults = {
1715             # Note: older versions are considered insecure, for example
1716             # search for "Poodle"-Attack
1717             method => 'any',
1718             sslv2 => 0,
1719             sslv3 => 0,
1720             cipher_list => 'ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES128-SHA256:ECDHE-RSA-AES128-SHA256',
1721             honor_cipher_order => 1,
1722         };
1723
1724         foreach my $k (keys %$ssl_defaults) {
1725             $self->{ssl}->{$k} //= $ssl_defaults->{$k};
1726         }
1727
1728         if (!defined($self->{ssl}->{dh_file})) {
1729             $self->{ssl}->{dh} = 'skip2048';
1730         }
1731
1732         my $tls_ctx_flags = &Net::SSLeay::OP_NO_COMPRESSION | &Net::SSLeay::OP_SINGLE_ECDH_USE | &Net::SSLeay::OP_SINGLE_DH_USE;
1733         if ( delete $self->{ssl}->{honor_cipher_order} ) {
1734             $tls_ctx_flags |= &Net::SSLeay::OP_CIPHER_SERVER_PREFERENCE;
1735         }
1736
1737         $self->{tls_ctx} = AnyEvent::TLS->new(%{$self->{ssl}});
1738         Net::SSLeay::CTX_set_options($self->{tls_ctx}->{ctx}, $tls_ctx_flags);
1739     }
1740
1741     if ($self->{spiceproxy}) {
1742         $known_methods = { CONNECT => 1 };
1743     }
1744
1745     $self->open_access_log($self->{logfile}) if $self->{logfile};
1746
1747     $self->{max_conn_soft_limit} = $self->{max_conn} > 100 ? $self->{max_conn} - 20 : $self->{max_conn};
1748
1749     $self->{socket_watch} = AnyEvent->io(fh => $self->{socket}, poll => 'r', cb => sub {
1750         eval {
1751             if ($self->{conn_count} >= $self->{max_conn}) {
1752                 my $w; $w = AnyEvent->timer (after => 1, interval => 1, cb => sub {
1753                     if ($self->{conn_count} < $self->{max_conn}) {
1754                         undef $w;
1755                         $self->accept_connections();
1756                     }
1757                 });
1758             } else {
1759                 $self->accept_connections();
1760             }
1761         };
1762         warn $@ if $@;
1763     });
1764
1765     $self->{term_watch} = AnyEvent->signal(signal => "TERM", cb => sub {
1766         undef $self->{term_watch};
1767         $self->wait_end_loop();
1768     });
1769
1770     $self->{quit_watch} = AnyEvent->signal(signal => "QUIT", cb => sub {
1771         undef $self->{quit_watch};
1772         $self->wait_end_loop();
1773     });
1774
1775     $self->{inotify_poll} = AnyEvent->timer(after => 5, interval => 5, cb => sub {
1776         PVE::INotify::poll(); # read inotify events
1777     });
1778
1779     return $self;
1780 }
1781
1782 # static helper to add directory including all subdirs
1783 # This can be used to setup $self->{dirs}
1784 sub add_dirs {
1785     my ($result_hash, $alias, $subdir) = @_;
1786
1787     $result_hash->{$alias} = $subdir;
1788
1789     my $wanted = sub {
1790         my $dir = $File::Find::dir;
1791         if ($dir =~m!^$subdir(.*)$!) {
1792             my $name = "$alias$1/";
1793             $result_hash->{$name} = "$dir/";
1794         }
1795     };
1796
1797     find({wanted => $wanted, follow => 0, no_chdir => 1}, $subdir);
1798 }
1799
1800 # abstract functions - subclass should overwrite/implement them
1801
1802 sub verify_spice_connect_url {
1803     my ($self, $connect_str) = @_;
1804
1805     die "implement me";
1806
1807     #return ($vmid, $node, $port);
1808 }
1809
1810 # formatters can call this when the generate a new page
1811 sub generate_csrf_prevention_token {
1812     my ($username) = @_;
1813
1814     return undef; # do nothing by default
1815 }
1816
1817 sub auth_handler {
1818     my ($self, $method, $rel_uri, $ticket, $token, $api_token, $peer_host) = @_;
1819
1820     die "implement me";
1821
1822     # return {
1823     #    ticket => $ticket,
1824     #    token => $token,
1825     #    userid => $username,
1826     #    age => $age,
1827     #    isUpload => $isUpload,
1828     #    api_token => $api_token,
1829     #};
1830 }
1831
1832 sub rest_handler {
1833     my ($self, $clientip, $method, $rel_uri, $auth, $params, $format) = @_;
1834
1835     # please do not raise exceptions here (always return a result).
1836
1837     return {
1838         status => HTTP_NOT_IMPLEMENTED,
1839         message => "Method '$method $rel_uri' not implemented",
1840     };
1841
1842     # this should return the following properties, which
1843     # are then passed to the Formatter
1844
1845     # status: HTTP status code
1846     # message: Error message
1847     # errors: more detailed error hash (per parameter)
1848     # info: reference to JSON schema definition - useful to format output
1849     # data: result data
1850
1851     # total: additional info passed to output
1852     # changes:  additional info passed to output
1853
1854     # if you want to proxy the request to another node return this
1855     # { proxy => $remip, proxynode => $node, proxy_params => $params };
1856
1857     # to pass the request to the local priviledged daemon use:
1858     # { proxy => 'localhost' , proxy_params => $params };
1859
1860     # to download aspecific file use:
1861     # { download => "/path/to/file" };
1862 }
1863
1864 sub check_cert_fingerprint {
1865     my ($self, $cert) = @_;
1866
1867      die "implement me";
1868  }
1869
1870 sub initialize_cert_cache {
1871     my ($self, $node) = @_;
1872
1873     die "implement me";
1874 }
1875
1876 sub remote_node_ip {
1877     my ($self, $node) = @_;
1878
1879     die "implement me";
1880
1881     # return $remip;
1882 }
1883
1884
1885 1;