miniserv.pl

   1 #!/usr/local/bin/perl
   2 # A very simple perl web server used by Webmin
   3
   4 # Require basic libraries
   5 package miniserv;
   6 use Socket;
   7 use POSIX;
   8 use Time::Local;
   9 eval "use Time::HiRes;";
  10
  11 @itoa64 = split(//, "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");
  12
  13 # Find and read config file
  14 if (@ARGV != 1) {
  15         die "Usage: miniserv.pl <config file>";
  16         }
  17 if ($ARGV[0] =~ /^([a-z]:)?\//i) {
  18         $config_file = $ARGV[0];
  19         }
  20 else {
  21         chop($pwd = `pwd`);
  22         $config_file = "$pwd/$ARGV[0]";
  23         }
  24 %config = &read_config_file($config_file);
  25 if ($config{'perllib'}) {
  26         push(@INC, split(/:/, $config{'perllib'}));
  27         $ENV{'PERLLIB'} .= ':'.$config{'perllib'};
  28         }
  29 @startup_msg = ( );
  30
  31 # Check if SSL is enabled and available
  32 if ($config{'ssl'}) {
  33         eval "use Net::SSLeay";
  34         if (!$@) {
  35                 $use_ssl = 1;
  36                 # These functions only exist for SSLeay 1.0
  37                 eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
  38                 eval "Net::SSLeay::load_error_strings()";
  39                 if ($config{'no_ssl2'}) {
  40                         eval "Net::SSLeay::CTX_set_options($ctx,&Net::SSLeay::OP_NO_SSLv2)";
  41                         }
  42                 if (defined(&Net::SSLeay::X509_STORE_CTX_get_current_cert) &&
  43                     defined(&Net::SSLeay::CTX_load_verify_locations) &&
  44                     defined(&Net::SSLeay::CTX_set_verify)) {
  45                         $client_certs = 1;
  46                         }
  47                 }
  48         }
  49
  50 # Check if IPv6 is enabled and available
  51 if ($config{'ipv6'}) {
  52         eval "use Socket6";
  53         if (!$@) {
  54                 push(@startup_msg, "IPv6 support enabled");
  55                 $use_ipv6 = 1;
  56                 }
  57         else {
  58                 push(@startup_msg, "IPv6 support cannot be enabled without ".
  59                                    "the Socket6 perl module");
  60                 }
  61         }
  62
  63 # Check if the syslog module is available to log hacking attempts
  64 if ($config{'syslog'} && !$config{'inetd'}) {
  65         eval "use Sys::Syslog qw(:DEFAULT setlogsock)";
  66         if (!$@) {
  67                 $use_syslog = 1;
  68                 }
  69         }
  70
  71 # check if the TCP-wrappers module is available
  72 if ($config{'libwrap'}) {
  73         eval "use Authen::Libwrap qw(hosts_ctl STRING_UNKNOWN)";
  74         if (!$@) {
  75                 $use_libwrap = 1;
  76                 }
  77         }
  78
  79 # Check if the MD5 perl module is available
  80 eval "use MD5";
  81 if (!$@) {
  82         $use_md5 = "MD5";
  83         }
  84 else {
  85         eval "use Digest::MD5";
  86         if (!$@) {
  87                 $use_md5 = "Digest::MD5";
  88                 }
  89         }
  90
  91 # Get miniserv's perl path and location
  92 $miniserv_path = $0;
  93 open(SOURCE, $miniserv_path);
  94 <SOURCE> =~ /^#!(\S+)/;
  95 $perl_path = $1;
  96 close(SOURCE);
  97 if (!-x $perl_path) {
  98         $perl_path = $^X;
  99         }
 100 if (-l $perl_path) {
 101         $linked_perl_path = readlink($perl_path);
 102         }
 103 @miniserv_argv = @ARGV;
 104
 105 # Check vital config options
 106 &update_vital_config();
 107
 108 $sidname = $config{'sidname'};
 109 die "Session authentication cannot be used in inetd mode"
 110         if ($config{'inetd'} && $config{'session'});
 111
 112 # check if the PAM module is available to authenticate
 113 if ($config{'assume_pam'}) {
 114         # Just assume that it will work. This can also be used to work around
 115         # a Solaris bug in which using PAM before forking caused it to fail
 116         # later!
 117         $use_pam = 1;
 118         }
 119 elsif (!$config{'no_pam'}) {
 120         eval "use Authen::PAM;";
 121         if (!$@) {
 122                 # check if the PAM authentication can be used by opening a
 123                 # PAM handle
 124                 local $pamh;
 125                 if (ref($pamh = new Authen::PAM($config{'pam'},
 126                                                 $config{'pam_test_user'},
 127                                                 \&pam_conv_func))) {
 128                         # Now test a login to see if /etc/pam.d/webmin is set
 129                         # up properly.
 130                         $pam_conv_func_called = 0;
 131                         $pam_username = "test";
 132                         $pam_password = "test";
 133                         $pamh->pam_authenticate();
 134                         if ($pam_conv_func_called) {
 135                                 push(@startup_msg,
 136                                      "PAM authentication enabled");
 137                                 $use_pam = 1;
 138                                 }
 139                         else {
 140                                 push(@startup_msg,
 141                                     "PAM test failed - maybe ".
 142                                     "/etc/pam.d/$config{'pam'} does not exist");
 143                                 }
 144                         }
 145                 else {
 146                         push(@startup_msg,
 147                              "PAM initialization of Authen::PAM failed");
 148                         }
 149                 }
 150         else {
 151                 push(@startup_msg,
 152                      "Perl module Authen::PAM needed for PAM is ".
 153                      "not installed : $@");
 154                 }
 155         }
 156 if ($config{'pam_only'} && !$use_pam) {
 157         print STDERR $startup_msg[0],"\n";
 158         print STDERR "PAM use is mandatory, but could not be enabled!\n";
 159         exit(1);
 160         }
 161 elsif ($pam_msg && !$use_pam) {
 162         push(@startup_msg,
 163              "Continuing without the Authen::PAM perl module");
 164         }
 165
 166 # Check if the User::Utmp perl module is installed
 167 if ($config{'utmp'}) {
 168         eval "use User::Utmp;";
 169         if (!$@) {
 170                 $write_utmp = 1;
 171                 push(@startup_msg, "UTMP logging enabled");
 172                 }
 173         else {
 174                 push(@startup_msg,
 175                      "Perl module User::Utmp needed for Utmp logging is ".
 176                      "not installed : $@");
 177                 }
 178         }
 179
 180 # See if the crypt function fails
 181 eval "crypt('foo', 'xx')";
 182 if ($@) {
 183         eval "use Crypt::UnixCrypt";
 184         if (!$@) {
 185                 $use_perl_crypt = 1;
 186                 push(@startup_msg,
 187                      "Using Crypt::UnixCrypt for password encryption");
 188                 }
 189         else {
 190                 push(@startup_msg,
 191                      "crypt() function un-implemented, and Crypt::UnixCrypt ".
 192                      "not installed - password authentication will fail");
 193                 }
 194         }
 195
 196 # Check if /dev/urandom really generates random IDs, by calling it twice
 197 local $rand1 = &generate_random_id("foo", 1);
 198 local $rand2 = &generate_random_id("foo", 2);
 199 if ($rand1 eq $rand2) {
 200         $bad_urandom = 1;
 201         push(@startup_msg,
 202              "Random number generator file /dev/urandom is not reliable");
 203         }
 204
 205 # Check if we can call sudo
 206 if ($config{'sudo'} && &has_command("sudo")) {
 207         eval "use IO::Pty";
 208         if (!$@) {
 209                 $use_sudo = 1;
 210                 }
 211         else {
 212                 push(@startup_msg,
 213                      "Perl module IO::Pty needed for calling sudo is not ".
 214                      "installed : $@");
 215                 }
 216         }
 217
 218 # init days and months for http_date
 219 @weekday = ( "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" );
 220 @month = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
 221            "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
 222
 223 # Change dir to the server root
 224 @roots = ( $config{'root'} );
 225 for($i=0; defined($config{"extraroot_$i"}); $i++) {
 226         push(@roots, $config{"extraroot_$i"});
 227         }
 228 chdir($roots[0]);
 229 eval { $user_homedir = (getpwuid($<))[7]; };
 230 if ($@) {
 231         # getpwuid doesn't work on windows
 232         $user_homedir = $ENV{"HOME"} || $ENV{"USERPROFILE"} || "/";
 233         $on_windows = 1;
 234         }
 235
 236 # Read users file
 237 &read_users_file();
 238
 239 # Setup SSL if possible and if requested
 240 if (!-r $config{'keyfile'}) {
 241         # Key file doesn't exist!
 242         if ($config{'keyfile'}) {
 243                 print STDERR "SSL key file $config{'keyfile'} does not exist\n";
 244                 }
 245         $use_ssl = 0;
 246         }
 247 elsif ($config{'certfile'} && !-r $config{'certfile'}) {
 248         # Cert file doesn't exist!
 249         print STDERR "SSL cert file $config{'certfile'} does not exist\n";
 250         $use_ssl = 0;
 251         }
 252 @ipkeys = &get_ipkeys(\%config);
 253 if ($use_ssl) {
 254         if ($config{'ssl_version'}) {
 255                 # Force an SSL version
 256                 $Net::SSLeay::version = $config{'ssl_version'};
 257                 $Net::SSLeay::ssl_version = $config{'ssl_version'};
 258                 }
 259         $client_certs = 0 if (!-r $config{'ca'} || !%certs);
 260         $ssl_contexts{"*"} = &create_ssl_context($config{'keyfile'},
 261                                                  $config{'certfile'});
 262         foreach $ipkey (@ipkeys) {
 263                 $ctx = &create_ssl_context($ipkey->{'key'}, $ipkey->{'cert'});
 264                 foreach $ip (@{$ipkey->{'ips'}}) {
 265                         $ssl_contexts{$ip} = $ctx;
 266                         }
 267                 }
 268         }
 269
 270 # Load gzip library if enabled
 271 if ($config{'gzip'} eq '1') {
 272         eval "use Compress::Zlib";
 273         if (!$@) {
 274                 $use_gzip = 1;
 275                 }
 276         }
 277
 278 # Setup syslog support if possible and if requested
 279 if ($use_syslog) {
 280         open(ERRDUP, ">&STDERR");
 281         open(STDERR, ">/dev/null");
 282         $log_socket = $config{"logsock"} || "unix";
 283         eval 'openlog($config{"pam"}, "cons,pid,ndelay", "authpriv"); setlogsock($log_socket)';
 284         if ($@) {
 285                 $use_syslog = 0;
 286                 }
 287         else {
 288                 local $msg = ucfirst($config{'pam'})." starting";
 289                 eval { syslog("info", "%s", $msg); };
 290                 if ($@) {
 291                         eval {
 292                                 setlogsock("inet");
 293                                 syslog("info", "%s", $msg);
 294                                 };
 295                         if ($@) {
 296                                 # All attempts to use syslog have failed..
 297                                 $use_syslog = 0;
 298                                 }
 299                         }
 300                 }
 301         open(STDERR, ">&ERRDUP");
 302         close(ERRDUP);
 303         }
 304
 305 # Read MIME types file and add extra types
 306 &read_mime_types();
 307
 308 # get the time zone
 309 if ($config{'log'}) {
 310         local(@gmt, @lct, $days, $hours, $mins);
 311         @gmt = gmtime(time());
 312         @lct = localtime(time());
 313         $days = $lct[3] - $gmt[3];
 314         $hours = ($days < -1 ? 24 : 1 < $days ? -24 : $days * 24) +
 315                  $lct[2] - $gmt[2];
 316         $mins = $hours * 60 + $lct[1] - $gmt[1];
 317         $timezone = ($mins < 0 ? "-" : "+"); $mins = abs($mins);
 318         $timezone .= sprintf "%2.2d%2.2d", $mins/60, $mins%60;
 319         }
 320
 321 # Build various maps from the config files
 322 &build_config_mappings();
 323
 324 # start up external authentication program, if needed
 325 if ($config{'extauth'}) {
 326         socketpair(EXTAUTH, EXTAUTH2, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
 327         if (!($extauth = fork())) {
 328                 close(EXTAUTH);
 329                 close(STDIN);
 330                 close(STDOUT);
 331                 open(STDIN, "<&EXTAUTH2");
 332                 open(STDOUT, ">&EXTAUTH2");
 333                 exec($config{'extauth'}) or die "exec failed : $!\n";
 334                 }
 335         close(EXTAUTH2);
 336         local $os = select(EXTAUTH);
 337         $| = 1; select($os);
 338         }
 339
 340 # Pre-load any libraries
 341 if (!$config{'inetd'}) {
 342         foreach $pl (split(/\s+/, $config{'preload'})) {
 343                 ($pkg, $lib) = split(/=/, $pl);
 344                 $pkg =~ s/[^A-Za-z0-9]/_/g;
 345                 eval "package $pkg; do '$config{'root'}/$lib'";
 346                 if ($@) {
 347                         print STDERR "Failed to pre-load $lib in $pkg : $@\n";
 348                         }
 349                 else {
 350                         print STDERR "Pre-loaded $lib in $pkg\n";
 351                         }
 352                 }
 353         foreach $pl (split(/\s+/, $config{'premodules'})) {
 354                 if ($pl =~ /\//) {
 355                         ($dir, $mod) = split(/\//, $pl);
 356                         }
 357                 else {
 358                         ($dir, $mod) = (undef, $pl);
 359                         }
 360                 push(@INC, "$config{'root'}/$dir");
 361                 eval "package $mod; use $mod ()";
 362                 if ($@) {
 363                         print STDERR "Failed to pre-load $mod : $@\n";
 364                         }
 365                 else {
 366                         print STDERR "Pre-loaded $mod\n";
 367                         }
 368                 }
 369         }
 370
 371 # Open debug log if set
 372 if ($config{'debuglog'}) {
 373         open(DEBUG, ">>$config{'debuglog'}");
 374         chmod(0700, $config{'debuglog'});
 375         select(DEBUG); $| = 1; select(STDOUT);
 376         print DEBUG "miniserv.pl starting ..\n";
 377         }
 378
 379 # Write out (empty) blocked hosts file
 380 &write_blocked_file();
 381
 382 # Initially read webmin cron functions and last execution times
 383 &read_webmin_crons();
 384 %webmincron_last = ( );
 385 &read_file($config{'webmincron_last'}, \%webmincron_last);
 386
 387 # Pre-cache lang files
 388 &precache_files();
 389
 390 if ($config{'inetd'}) {
 391         # We are being run from inetd - go direct to handling the request
 392         &redirect_stderr_to_log();
 393         $SIG{'HUP'} = 'IGNORE';
 394         $SIG{'TERM'} = 'DEFAULT';
 395         $SIG{'PIPE'} = 'DEFAULT';
 396         open(SOCK, "+>&STDIN");
 397
 398         # Check if it is time for the logfile to be cleared
 399         if ($config{'logclear'}) {
 400                 local $write_logtime = 0;
 401                 local @st = stat("$config{'logfile'}.time");
 402                 if (@st) {
 403                         if ($st[9]+$config{'logtime'}*60*60 < time()){
 404                                 # need to clear log
 405                                 $write_logtime = 1;
 406                                 unlink($config{'logfile'});
 407                                 }
 408                         }
 409                 else { $write_logtime = 1; }
 410                 if ($write_logtime) {
 411                         open(LOGTIME, ">$config{'logfile'}.time");
 412                         print LOGTIME time(),"\n";
 413                         close(LOGTIME);
 414                         }
 415                 }
 416
 417         # Initialize SSL for this connection
 418         if ($use_ssl) {
 419                 $ssl_con = &ssl_connection_for_ip(SOCK, 0);
 420                 $ssl_con || exit;
 421                 }
 422
 423         # Work out the hostname for this web server
 424         $host = &get_socket_name(SOCK, 0);
 425         $host || exit;
 426         $port = $config{'port'};
 427         $acptaddr = getpeername(SOCK);
 428         $acptaddr || exit;
 429
 430         # Work out remote and local IPs
 431         $ipv6 = length($acptaddr) > 16;
 432         (undef, $peera, undef) = &get_address_ip($acptaddr, $ipv6);
 433         (undef, $locala) = &get_socket_ip(SOCK, $ipv6);
 434
 435         print DEBUG "main: Starting handle_request loop pid=$$\n";
 436         while(&handle_request($peera, $locala, $ipv6)) { }
 437         print DEBUG "main: Done handle_request loop pid=$$\n";
 438         close(SOCK);
 439         exit;
 440         }
 441
 442 # Build list of sockets to listen on
 443 $config{'bind'} = '' if ($config{'bind'} eq '*');
 444 if ($config{'bind'}) {
 445         # Listening on a specific IP
 446         if (&check_ip6address($config{'bind'})) {
 447                 # IP is v6
 448                 $use_ipv6 || die "Cannot bind to $config{'bind'} without IPv6";
 449                 push(@sockets, [ inet_pton(Socket6::AF_INET6(),$config{'bind'}),
 450                                  $config{'port'},
 451                                  Socket6::PF_INET6() ]);
 452                 }
 453         else {
 454                 # IP is v4
 455                 push(@sockets, [ inet_aton($config{'bind'}),
 456                                  $config{'port'},
 457                                  PF_INET() ]);
 458                 }
 459         }
 460 else {
 461         # Listening on all IPs
 462         push(@sockets, [ INADDR_ANY, $config{'port'}, PF_INET() ]);
 463         if ($use_ipv6) {
 464                 # Also IPv6
 465                 push(@sockets, [ in6addr_any(), $config{'port'},
 466                                  Socket6::PF_INET6() ]);
 467                 }
 468         }
 469 foreach $s (split(/\s+/, $config{'sockets'})) {
 470         if ($s =~ /^(\d+)$/) {
 471                 # Just listen on another port on the main IP
 472                 push(@sockets, [ $sockets[0]->[0], $s, $sockets[0]->[2] ]);
 473                 if ($use_ipv6 && !$config{'bind'}) {
 474                         # Also listen on that port on the main IPv6 address
 475                         push(@sockets, [ $sockets[1]->[0], $s,
 476                                          $sockets[1]->[2] ]);
 477                         }
 478                 }
 479         elsif ($s =~ /^\*:(\d+)$/) {
 480                 # Listening on all IPs on some port
 481                 push(@sockets, [ INADDR_ANY, $1,
 482                                  PF_INET() ]);
 483                 if ($use_ipv6) {
 484                         push(@sockets, [ in6addr_any(), $1,
 485                                          Socket6::PF_INET6() ]);
 486                         }
 487                 }
 488         elsif ($s =~ /^(\S+):(\d+)$/) {
 489                 # Listen on a specific port and IP
 490                 my ($ip, $port) = ($1, $2);
 491                 if (&check_ip6address($ip)) {
 492                         $use_ipv6 || die "Cannot bind to $ip without IPv6";
 493                         push(@sockets, [ inet_pton(Socket6::AF_INET6(),
 494                                                    $ip),
 495                                          $port, Socket6::PF_INET6() ]);
 496                         }
 497                 else {
 498                         push(@sockets, [ inet_aton($ip), $port,
 499                                          PF_INET() ]);
 500                         }
 501                 }
 502         elsif ($s =~ /^([0-9\.]+):\*$/ || $s =~ /^([0-9\.]+)$/) {
 503                 # Listen on the main port on another IPv4 address
 504                 push(@sockets, [ inet_aton($1), $sockets[0]->[1],
 505                                  PF_INET() ]);
 506                 }
 507         elsif (($s =~ /^([0-9a-f\:]+):\*$/ || $s =~ /^([0-9a-f\:]+)$/) &&
 508                $use_ipv6) {
 509                 # Listen on the main port on another IPv6 address
 510                 push(@sockets, [ inet_pton(Socket6::AF_INET6(), $1),
 511                                  $sockets[0]->[1],
 512                                  Socket6::PF_INET6() ]);
 513                 }
 514         }
 515
 516 # Open all the sockets
 517 $proto = getprotobyname('tcp');
 518 @sockerrs = ( );
 519 $tried_inaddr_any = 0;
 520 for($i=0; $i<@sockets; $i++) {
 521         $fh = "MAIN$i";
 522         socket($fh, $sockets[$i]->[2], SOCK_STREAM, $proto) ||
 523                 die "Failed to open socket family $sockets[$i]->[2] : $!";
 524         setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
 525         if ($sockets[$i]->[2] eq PF_INET()) {
 526                 $pack = pack_sockaddr_in($sockets[$i]->[1], $sockets[$i]->[0]);
 527                 }
 528         else {
 529                 $pack = pack_sockaddr_in6($sockets[$i]->[1], $sockets[$i]->[0]);
 530                 setsockopt($fh, 41, 26, pack("l", 1));  # IPv6 only
 531                 }
 532         for($j=0; $j<5; $j++) {
 533                 last if (bind($fh, $pack));
 534                 sleep(1);
 535                 }
 536         if ($j == 5) {
 537                 # All attempts failed .. give up
 538                 if ($sockets[$i]->[0] eq INADDR_ANY ||
 539                     $use_ipv6 && $sockets[$i]->[0] eq in6addr_any()) {
 540                         push(@sockerrs,
 541                              "Failed to bind to port $sockets[$i]->[1] : $!");
 542                         $tried_inaddr_any = 1;
 543                         }
 544                 else {
 545                         $ip = &network_to_address($sockets[$i]->[0]);
 546                         push(@sockerrs,
 547                              "Failed to bind to IP $ip port ".
 548                              "$sockets[$i]->[1] : $!");
 549                         }
 550                 }
 551         else {
 552                 listen($fh, SOMAXCONN);
 553                 push(@socketfhs, $fh);
 554                 $ipv6fhs{$fh} = $sockets[$i]->[2] eq PF_INET() ? 0 : 1;
 555                 }
 556         }
 557 foreach $se (@sockerrs) {
 558         print STDERR $se,"\n";
 559         }
 560
 561 # If all binds failed, try binding to any address
 562 if (!@socketfhs && !$tried_inaddr_any) {
 563         print STDERR "Falling back to listening on any address\n";
 564         $fh = "MAIN";
 565         socket($fh, PF_INET(), SOCK_STREAM, $proto) ||
 566                 die "Failed to open socket : $!";
 567         setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
 568         if (!bind($fh, pack_sockaddr_in($sockets[0]->[1], INADDR_ANY))) {
 569                 print STDERR "Failed to bind to port $sockets[0]->[1] : $!\n";
 570                 exit(1);
 571                 }
 572         listen($fh, SOMAXCONN);
 573         push(@socketfhs, $fh);
 574         }
 575 elsif (!@socketfhs && $tried_inaddr_any) {
 576         print STDERR "Could not listen on any ports";
 577         exit(1);
 578         }
 579
 580 if ($config{'listen'}) {
 581         # Open the socket that allows other webmin servers to find this one
 582         $proto = getprotobyname('udp');
 583         if (socket(LISTEN, PF_INET(), SOCK_DGRAM, $proto)) {
 584                 setsockopt(LISTEN, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
 585                 bind(LISTEN, pack_sockaddr_in($config{'listen'}, INADDR_ANY));
 586                 listen(LISTEN, SOMAXCONN);
 587                 }
 588         else {
 589                 $config{'listen'} = 0;
 590                 }
 591         }
 592
 593 # Split from the controlling terminal, unless configured not to
 594 if (!$config{'nofork'}) {
 595         if (fork()) { exit; }
 596         }
 597 eval { setsid(); };     # may not work on Windows
 598
 599 # Close standard file handles
 600 open(STDIN, "</dev/null");
 601 open(STDOUT, ">/dev/null");
 602 &redirect_stderr_to_log();
 603 &log_error("miniserv.pl started");
 604 foreach $msg (@startup_msg) {
 605         &log_error($msg);
 606         }
 607
 608 # write out the PID file
 609 &write_pid_file();
 610
 611 # Start the log-clearing process, if needed. This checks every minute
 612 # to see if the log has passed its reset time, and if so clears it
 613 if ($config{'logclear'}) {
 614         if (!($logclearer = fork())) {
 615                 &close_all_sockets();
 616                 close(LISTEN);
 617                 while(1) {
 618                         local $write_logtime = 0;
 619                         local @st = stat("$config{'logfile'}.time");
 620                         if (@st) {
 621                                 if ($st[9]+$config{'logtime'}*60*60 < time()){
 622                                         # need to clear log
 623                                         $write_logtime = 1;
 624                                         unlink($config{'logfile'});
 625                                         }
 626                                 }
 627                         else { $write_logtime = 1; }
 628                         if ($write_logtime) {
 629                                 open(LOGTIME, ">$config{'logfile'}.time");
 630                                 print LOGTIME time(),"\n";
 631                                 close(LOGTIME);
 632                                 }
 633                         sleep(5*60);
 634                         }
 635                 exit;
 636                 }
 637         push(@childpids, $logclearer);
 638         }
 639
 640 # Setup the logout time dbm if needed
 641 if ($config{'session'}) {
 642         eval "use SDBM_File";
 643         dbmopen(%sessiondb, $config{'sessiondb'}, 0700);
 644         eval "\$sessiondb{'1111111111'} = 'foo bar';";
 645         if ($@) {
 646                 dbmclose(%sessiondb);
 647                 eval "use NDBM_File";
 648                 dbmopen(%sessiondb, $config{'sessiondb'}, 0700);
 649                 }
 650         else {
 651                 delete($sessiondb{'1111111111'});
 652                 }
 653         }
 654
 655 # Run the main loop
 656 $SIG{'HUP'} = 'miniserv::trigger_restart';
 657 $SIG{'TERM'} = 'miniserv::term_handler';
 658 $SIG{'USR1'} = 'miniserv::trigger_reload';
 659 $SIG{'PIPE'} = 'IGNORE';
 660 local $remove_session_count = 0;
 661 $need_pipes = $config{'passdelay'} || $config{'session'};
 662 while(1) {
 663         # wait for a new connection, or a message from a child process
 664         local ($i, $rmask);
 665         if (@childpids <= $config{'maxconns'}) {
 666                 # Only accept new main socket connects when ready
 667                 local $s;
 668                 foreach $s (@socketfhs) {
 669                         vec($rmask, fileno($s), 1) = 1;
 670                         }
 671                 }
 672         else {
 673                 printf STDERR "too many children (%d > %d)\n",
 674                         scalar(@childpids), $config{'maxconns'};
 675                 }
 676         if ($need_pipes) {
 677                 for($i=0; $i<@passin; $i++) {
 678                         vec($rmask, fileno($passin[$i]), 1) = 1;
 679                         }
 680                 }
 681         vec($rmask, fileno(LISTEN), 1) = 1 if ($config{'listen'});
 682
 683         # Wait for a connection
 684         local $sel = select($rmask, undef, undef, 10);
 685
 686         # Check the flag files
 687         if ($config{'restartflag'} && -r $config{'restartflag'}) {
 688                 print STDERR "restart flag file detected\n";
 689                 unlink($config{'restartflag'});
 690                 $need_restart = 1;
 691                 }
 692         if ($config{'reloadflag'} && -r $config{'reloadflag'}) {
 693                 unlink($config{'reloadflag'});
 694                 $need_reload = 1;
 695                 }
 696
 697         if ($need_restart) {
 698                 # Got a HUP signal while in select() .. restart now
 699                 &restart_miniserv();
 700                 }
 701         if ($need_reload) {
 702                 # Got a USR1 signal while in select() .. re-read config
 703                 $need_reload = 0;
 704                 &reload_config_file();
 705                 }
 706         local $time_now = time();
 707
 708         # Clean up finished processes
 709         local $pid;
 710         do {    $pid = waitpid(-1, WNOHANG);
 711                 @childpids = grep { $_ != $pid } @childpids;
 712                 } while($pid != 0 && $pid != -1);
 713
 714         # run the unblocking procedure to check if enough time has passed to
 715         # unblock hosts that heve been blocked because of password failures
 716         $unblocked = 0;
 717         if ($config{'blockhost_failures'}) {
 718                 $i = 0;
 719                 while ($i <= $#deny) {
 720                         if ($blockhosttime{$deny[$i]} &&
 721                             $config{'blockhost_time'} != 0 &&
 722                             ($time_now - $blockhosttime{$deny[$i]}) >=
 723                              $config{'blockhost_time'}) {
 724                                 # the host can be unblocked now
 725                                 $hostfail{$deny[$i]} = 0;
 726                                 splice(@deny, $i, 1);
 727                                 $unblocked = 1;
 728                                 }
 729                         $i++;
 730                         }
 731                 }
 732
 733         # Do the same for blocked users
 734         if ($config{'blockuser_failures'}) {
 735                 $i = 0;
 736                 while ($i <= $#deny) {
 737                         if ($blockusertime{$deny[$i]} &&
 738                             $config{'blockuser_time'} != 0 &&
 739                             ($time_now - $blockusertime{$deny[$i]}) >=
 740                              $config{'blockuser_time'}) {
 741                                 # the user can be unblocked now
 742                                 $userfail{$deny[$i]} = 0;
 743                                 splice(@denyusers, $i, 1);
 744                                 $unblocked = 1;
 745                                 }
 746                         $i++;
 747                         }
 748                 }
 749         if ($unblocked) {
 750                 &write_blocked_file();
 751                 }
 752
 753         # Check if any webmin cron jobs are ready to run
 754         &execute_ready_webmin_crons();
 755
 756         if ($config{'session'} && (++$remove_session_count%50) == 0) {
 757                 # Remove sessions with more than 7 days of inactivity,
 758                 local $s;
 759                 foreach $s (keys %sessiondb) {
 760                         local ($user, $ltime, $lip) =
 761                                 split(/\s+/, $sessiondb{$s});
 762                         if ($time_now - $ltime > 7*24*60*60) {
 763                                 &run_logout_script($s, $user);
 764                                 &write_logout_utmp($user, $lip);
 765                                 delete($sessiondb{$s});
 766                                 if ($use_syslog) {
 767                                         syslog("info", "%s",
 768                                               "Timeout of session for $user");
 769                                         }
 770                                 }
 771                         }
 772                 }
 773
 774         if ($use_pam && $config{'pam_conv'}) {
 775                 # Remove PAM sessions with more than 5 minutes of inactivity
 776                 local $c;
 777                 foreach $c (values %conversations) {
 778                         if ($time_now - $c->{'time'} > 5*60) {
 779                                 &end_pam_conversation($c);
 780                                 if ($use_syslog) {
 781                                         syslog("info", "%s", "Timeout of PAM ".
 782                                                 "session for $c->{'user'}");
 783                                         }
 784                                 }
 785                         }
 786                 }
 787
 788         # Don't check any sockets if there is no activity
 789         next if ($sel <= 0);
 790
 791         # Check if any of the main sockets have received a new connection
 792         local $sn = 0;
 793         foreach $s (@socketfhs) {
 794                 if (vec($rmask, fileno($s), 1)) {
 795                         # got new connection
 796                         $acptaddr = accept(SOCK, $s);
 797                         if (!$acptaddr) { next; }
 798                         binmode(SOCK);  # turn off any Perl IO stuff
 799
 800                         # create pipes
 801                         local ($PASSINr, $PASSINw, $PASSOUTr, $PASSOUTw);
 802                         if ($need_pipes) {
 803                                 ($PASSINr, $PASSINw, $PASSOUTr, $PASSOUTw) =
 804                                         &allocate_pipes();
 805                                 }
 806
 807                         # Work out IP and port of client
 808                         local ($peerb, $peera, $peerp) =
 809                                 &get_address_ip($acptaddr, $ipv6fhs{$s});
 810
 811                         # Work out the local IP
 812                         (undef, $locala) = &get_socket_ip(SOCK, $ipv6fhs{$s});
 813
 814                         # Check username of connecting user
 815                         $localauth_user = undef;
 816                         if ($config{'localauth'} && $peera eq "127.0.0.1") {
 817                                 if (open(TCP, "/proc/net/tcp")) {
 818                                         # Get the info direct from the kernel
 819                                         $peerh = sprintf("%4.4X", $peerp);
 820                                         while(<TCP>) {
 821                                                 s/^\s+//;
 822                                                 local @t = split(/[\s:]+/, $_);
 823                                                 if ($t[1] eq '0100007F' &&
 824                                                     $t[2] eq $peerh) {
 825                                                         $localauth_user =
 826                                                             getpwuid($t[11]);
 827                                                         last;
 828                                                         }
 829                                                 }
 830                                         close(TCP);
 831                                         }
 832                                 if (!$localauth_user) {
 833                                         # Call lsof for the info
 834                                         local $lsofpid = open(LSOF,
 835                                                 "$config{'localauth'} -i ".
 836                                                 "TCP\@127.0.0.1:$peerp |");
 837                                         while(<LSOF>) {
 838                                                 if (/^(\S+)\s+(\d+)\s+(\S+)/ &&
 839                                                     $2 != $$ && $2 != $lsofpid){
 840                                                         $localauth_user = $3;
 841                                                         }
 842                                                 }
 843                                         close(LSOF);
 844                                         }
 845                                 }
 846
 847                         # Work out the hostname for this web server
 848                         $host = &get_socket_name(SOCK, $ipv6fhs{$s});
 849                         if (!$host) {
 850                                 print STDERR
 851                                     "Failed to get local socket name : $!\n";
 852                                 close(SOCK);
 853                                 next;
 854                                 }
 855                         $port = $sockets[$sn]->[1];
 856
 857                         # fork the subprocess
 858                         local $handpid;
 859                         if (!($handpid = fork())) {
 860                                 # setup signal handlers
 861                                 $SIG{'TERM'} = 'DEFAULT';
 862                                 $SIG{'PIPE'} = 'DEFAULT';
 863                                 #$SIG{'CHLD'} = 'IGNORE';
 864                                 $SIG{'HUP'} = 'IGNORE';
 865                                 $SIG{'USR1'} = 'IGNORE';
 866
 867                                 # Initialize SSL for this connection
 868                                 if ($use_ssl) {
 869                                         $ssl_con = &ssl_connection_for_ip(
 870                                                         SOCK, $ipv6fhs{$s});
 871                                         $ssl_con || exit;
 872                                         }
 873
 874                                 # Close the file handle for the session DBM
 875                                 dbmclose(%sessiondb);
 876
 877                                 # close useless pipes
 878                                 if ($need_pipes) {
 879                                         &close_all_pipes();
 880                                         close($PASSINr); close($PASSOUTw);
 881                                         }
 882                                 &close_all_sockets();
 883                                 close(LISTEN);
 884
 885                                 print DEBUG
 886                                   "main: Starting handle_request loop pid=$$\n";
 887                                 while(&handle_request($peera, $locala,
 888                                                       $ipv6fhs{$s})) {
 889                                         # Loop until keepalive stops
 890                                         }
 891                                 print DEBUG
 892                                   "main: Done handle_request loop pid=$$\n";
 893                                 shutdown(SOCK, 1);
 894                                 close(SOCK);
 895                                 close($PASSINw); close($PASSOUTw);
 896                                 exit;
 897                                 }
 898                         push(@childpids, $handpid);
 899                         if ($need_pipes) {
 900                                 close($PASSINw); close($PASSOUTr);
 901                                 push(@passin, $PASSINr);
 902                                 push(@passout, $PASSOUTw);
 903                                 }
 904                         close(SOCK);
 905                         }
 906                 $sn++;
 907                 }
 908
 909         if ($config{'listen'} && vec($rmask, fileno(LISTEN), 1)) {
 910                 # Got UDP packet from another webmin server
 911                 local $rcvbuf;
 912                 local $from = recv(LISTEN, $rcvbuf, 1024, 0);
 913                 next if (!$from);
 914                 local $fromip = inet_ntoa((unpack_sockaddr_in($from))[1]);
 915                 local $toip = inet_ntoa((unpack_sockaddr_in(
 916                                          getsockname(LISTEN)))[1]);
 917                 if ((!@deny || !&ip_match($fromip, $toip, @deny)) &&
 918                     (!@allow || &ip_match($fromip, $toip, @allow))) {
 919                         local $listenhost = &get_socket_name(LISTEN, 0);
 920                         send(LISTEN, "$listenhost:$config{'port'}:".
 921                                  ($use_ssl || $config{'inetd_ssl'} ? 1 : 0).":".
 922                                  ($config{'listenhost'} ?
 923                                         &get_system_hostname() : ""),
 924                                  0, $from)
 925                                 if ($listenhost);
 926                         }
 927                 }
 928
 929         # check for session, password-timeout and PAM messages from subprocesses
 930         for($i=0; $i<@passin; $i++) {
 931                 if (vec($rmask, fileno($passin[$i]), 1)) {
 932                         # this sub-process is asking about a password
 933                         local $infd = $passin[$i];
 934                         local $outfd = $passout[$i];
 935                         #local $inline = <$infd>;
 936                         local $inline = &sysread_line($infd);
 937                         if ($inline) {
 938                                 print DEBUG "main: inline $inline";
 939                                 }
 940                         else {
 941                                 print DEBUG "main: inline EOF\n";
 942                                 }
 943                         if ($inline =~ /^delay\s+(\S+)\s+(\S+)\s+(\d+)/) {
 944                                 # Got a delay request from a subprocess.. for
 945                                 # valid logins, there is no delay (to prevent
 946                                 # denial of service attacks), but for invalid
 947                                 # logins the delay increases with each failed
 948                                 # attempt.
 949                                 if ($3) {
 950                                         # login OK.. no delay
 951                                         print $outfd "0 0\n";
 952                                         $wasblocked = $hostfail{$2} ||
 953                                                       $userfail{$1};
 954                                         $hostfail{$2} = 0;
 955                                         $userfail{$1} = 0;
 956                                         if ($wasblocked) {
 957                                                 &write_blocked_file();
 958                                                 }
 959                                         }
 960                                 else {
 961                                         # login failed..
 962                                         $hostfail{$2}++;
 963                                         $userfail{$1}++;
 964                                         $blocked = 0;
 965
 966                                         # add the host to the block list,
 967                                         # if configured
 968                                         if ($config{'blockhost_failures'} &&
 969                                             $hostfail{$2} >=
 970                                               $config{'blockhost_failures'}) {
 971                                                 push(@deny, $2);
 972                                                 $blockhosttime{$2} = $time_now;
 973                                                 $blocked = 1;
 974                                                 if ($use_syslog) {
 975                                                         local $logtext = "Security alert: Host $2 blocked after $config{'blockhost_failures'} failed logins for user $1";
 976                                                         syslog("crit", "%s",
 977                                                                 $logtext);
 978                                                         }
 979                                                 }
 980
 981                                         # add the user to the user block list,
 982                                         # if configured
 983                                         if ($config{'blockuser_failures'} &&
 984                                             $userfail{$1} >=
 985                                               $config{'blockuser_failures'}) {
 986                                                 push(@denyusers, $1);
 987                                                 $blockusertime{$1} = $time_now;
 988                                                 $blocked = 2;
 989                                                 if ($use_syslog) {
 990                                                         local $logtext = "Security alert: User $1 blocked after $config{'blockuser_failures'} failed logins";
 991                                                         syslog("crit", "%s",
 992                                                                 $logtext);
 993                                                         }
 994                                                 }
 995
 996                                         # Lock out the user's password, if enabled
 997                                         if ($config{'blocklock'} &&
 998                                             $userfail{$1} >=
 999                                               $config{'blockuser_failures'}) {
1000                                                 my $lk = &lock_user_password($1);
1001                                                 $blocked = 2;
1002                                                 if ($use_syslog) {
1003                                                         local $logtext = $lk == 1 ? "Security alert: User $1 locked after $config{'blockuser_failures'} failed logins" : $lk < 0 ? "Security alert: User could not be locked" : "Security alert: User is already locked";
1004                                                         syslog("crit", "%s",
1005                                                                 $logtext);
1006                                                         }
1007                                                 }
1008
1009                                         # Send back a delay
1010                                         $dl = $userdlay{$1} -
1011                                            int(($time_now - $userlast{$1})/50);
1012                                         $dl = $dl < 0 ? 0 : $dl+1;
1013                                         print $outfd "$dl $blocked\n";
1014                                         $userdlay{$1} = $dl;
1015
1016                                         # Write out blocked status file
1017                                         if ($blocked) {
1018                                                 &write_blocked_file();
1019                                                 }
1020                                         }
1021                                 $userlast{$1} = $time_now;
1022                                 }
1023                         elsif ($inline =~ /^verify\s+(\S+)\s+(\S+)/) {
1024                                 # Verifying a session ID
1025                                 local $session_id = $1;
1026                                 local $notimeout = $2;
1027                                 local $skey = $sessiondb{$session_id} ?
1028                                                 $session_id :
1029                                                 &hash_session_id($session_id);
1030                                 if (!defined($sessiondb{$skey})) {
1031                                         # Session doesn't exist
1032                                         print $outfd "0 0\n";
1033                                         }
1034                                 else {
1035                                         local ($user, $ltime) =
1036                                           split(/\s+/, $sessiondb{$skey});
1037                                         local $lot = &get_logout_time($user, $session_id);
1038                                         if ($lot &&
1039                                             $time_now - $ltime > $lot*60 &&
1040                                             !$notimeout) {
1041                                                 # Session has timed out
1042                                                 print $outfd "1 ",$time_now - $ltime,"\n";
1043                                                 #delete($sessiondb{$skey});
1044                                                 }
1045                                         else {
1046                                                 # Session is OK
1047                                                 print $outfd "2 $user\n";
1048                                                 if ($lot &&
1049                                                     $time_now - $ltime >
1050                                                     ($lot*60)/2) {
1051                                                         $sessiondb{$skey} = "$user $time_now";
1052                                                         }
1053                                                 }
1054                                         }
1055                                 }
1056                         elsif ($inline =~ /^new\s+(\S+)\s+(\S+)\s+(\S+)/) {
1057                                 # Creating a new session
1058                                 local $session_id = $1;
1059                                 local $user = $2;
1060                                 local $ip = $3;
1061                                 $sessiondb{&hash_session_id($session_id)} =
1062                                         "$user $time_now $ip";
1063                                 }
1064                         elsif ($inline =~ /^delete\s+(\S+)/) {
1065                                 # Logging out a session
1066                                 local $session_id = $1;
1067                                 local $skey = $sessiondb{$session_id} ?
1068                                                 $session_id :
1069                                                 &hash_session_id($session_id);
1070                                 local @sdb = split(/\s+/, $sessiondb{$skey});
1071                                 print $outfd $sdb[0],"\n";
1072                                 delete($sessiondb{$skey});
1073                                 }
1074                         elsif ($inline =~ /^pamstart\s+(\S+)\s+(\S+)\s+(.*)/) {
1075                                 # Starting a new PAM conversation
1076                                 local ($cid, $host, $user) = ($1, $2, $3);
1077
1078                                 # Does this user even need PAM?
1079                                 local ($realuser, $canlogin) =
1080                                         &can_user_login($user, undef, $host);
1081                                 local $conv;
1082                                 if ($canlogin == 0) {
1083                                         # Cannot even login!
1084                                         print $outfd "0 Invalid username\n";
1085                                         }
1086                                 elsif ($canlogin != 2) {
1087                                         # Not using PAM .. so just ask for
1088                                         # the password.
1089                                         $conv = { 'user' => $realuser,
1090                                                   'host' => $host,
1091                                                   'step' => 0,
1092                                                   'cid' => $cid,
1093                                                   'time' => time() };
1094                                         print $outfd "3 Password\n";
1095                                         }
1096                                 else {
1097                                         # Start the PAM conversation
1098                                         # sub-process, and get a question
1099                                         $conv = { 'user' => $realuser,
1100                                                   'host' => $host,
1101                                                   'cid' => $cid,
1102                                                   'time' => time() };
1103                                         local ($PAMINr, $PAMINw, $PAMOUTr,
1104                                                 $PAMOUTw) = &allocate_pipes();
1105                                         local $pampid = fork();
1106                                         if (!$pampid) {
1107                                                 close($PAMOUTr); close($PAMINw);
1108                                                 &pam_conversation_process(
1109                                                         $realuser,
1110                                                         $PAMOUTw, $PAMINr);
1111                                                 }
1112                                         close($PAMOUTw); close($PAMINr);
1113                                         $conv->{'pid'} = $pampid;
1114                                         $conv->{'PAMOUTr'} = $PAMOUTr;
1115                                         $conv->{'PAMINw'} = $PAMINw;
1116                                         push(@childpids, $pampid);
1117
1118                                         # Get the first PAM question
1119                                         local $pok = &recv_pam_question(
1120                                                 $conv, $outfd);
1121                                         if (!$pok) {
1122                                                 &end_pam_conversation($conv);
1123                                                 }
1124                                         }
1125
1126                                 $conversations{$cid} = $conv if ($conv);
1127                                 }
1128                         elsif ($inline =~ /^pamanswer\s+(\S+)\s+(.*)/) {
1129                                 # A response to a PAM question
1130                                 local ($cid, $answer) = ($1, $2);
1131                                 local $conv = $conversations{$cid};
1132                                 if (!$conv) {
1133                                         # No such conversation?
1134                                         print $outfd "0 Bad login session\n";
1135                                         }
1136                                 elsif ($conv->{'pid'}) {
1137                                         # Send the PAM response and get
1138                                         # the next question
1139                                         &send_pam_answer($conv, $answer);
1140                                         local $pok = &recv_pam_question($conv, $outfd);
1141                                         if (!$pok) {
1142                                                 &end_pam_conversation($conv);
1143                                                 }
1144                                         }
1145                                 else {
1146                                         # This must be the password .. try it
1147                                         # and send back the results
1148                                         local ($vu, $expired, $nonexist) =
1149                                                 &validate_user($conv->{'user'},
1150                                                                $answer,
1151                                                                $conf->{'host'});
1152                                         local $ok = $vu ? 1 : 0;
1153                                         print $outfd "2 $conv->{'user'} $ok $expired $notexist\n";
1154                                         &end_pam_conversation($conv);
1155                                         }
1156                                 }
1157                         elsif ($inline =~ /^writesudo\s+(\S+)\s+(\d+)/) {
1158                                 # Store the fact that some user can sudo to root
1159                                 local ($user, $ok) = ($1, $2);
1160                                 $sudocache{$user} = $ok." ".time();
1161                                 }
1162                         elsif ($inline =~ /^readsudo\s+(\S+)/) {
1163                                 # Query the user sudo cache (valid for 1 minute)
1164                                 local $user = $1;
1165                                 local ($ok, $last) =
1166                                         split(/\s+/, $sudocache{$user});
1167                                 if ($last < time()-60) {
1168                                         # Cache too old
1169                                         print $outfd "2\n";
1170                                         }
1171                                 else {
1172                                         # Tell client OK or not
1173                                         print $outfd "$ok\n";
1174                                         }
1175                                 }
1176                         elsif ($inline =~ /\S/) {
1177                                 # Unknown line from pipe?
1178                                 print DEBUG "main: Unknown line from pipe $inline\n";
1179                                 print STDERR "Unknown line from pipe $inline\n";
1180                                 }
1181                         else {
1182                                 # close pipe
1183                                 close($infd); close($outfd);
1184                                 $passin[$i] = $passout[$i] = undef;
1185                                 }
1186                         }
1187                 }
1188         @passin = grep { defined($_) } @passin;
1189         @passout = grep { defined($_) } @passout;
1190         }
1191
1192 # handle_request(remoteaddress, localaddress, ipv6-flag)
1193 # Where the real work is done
1194 sub handle_request
1195 {
1196 local ($acptip, $localip, $ipv6) = @_;
1197 print DEBUG "handle_request: from $acptip to $localip ipv6=$ipv6\n";
1198 if ($config{'loghost'}) {
1199         $acpthost = &to_hostname($acptip);
1200         $acpthost = $acptip if (!$acpthost);
1201         }
1202 else {
1203         $acpthost = $acptip;
1204         }
1205 $datestr = &http_date(time());
1206 $ok_code = 200;
1207 $ok_message = "Document follows";
1208 $logged_code = undef;
1209 $reqline = $request_uri = $page = undef;
1210 $authuser = undef;
1211 $validated = undef;
1212
1213 # check address against access list
1214 if (@deny && &ip_match($acptip, $localip, @deny) ||
1215     @allow && !&ip_match($acptip, $localip, @allow)) {
1216         &http_error(403, "Access denied for $acptip");
1217         return 0;
1218         }
1219
1220 if ($use_libwrap) {
1221         # Check address with TCP-wrappers
1222         if (!hosts_ctl($config{'pam'}, STRING_UNKNOWN,
1223                        $acptip, STRING_UNKNOWN)) {
1224                 &http_error(403, "Access denied for $acptip by TCP wrappers");
1225                 return 0;
1226                 }
1227         }
1228 print DEBUG "handle_request: passed IP checks\n";
1229
1230 # Compute a timeout for the start of headers, based on the number of
1231 # child processes. As this increases, we use a shorter timeout to avoid
1232 # an attacker overloading the system.
1233 local $header_timeout = 60 + ($config{'maxconns'} - @childpids) * 10;
1234
1235 # Wait at most 60 secs for start of headers for initial requests, or
1236 # 10 minutes for kept-alive connections
1237 local $rmask;
1238 vec($rmask, fileno(SOCK), 1) = 1;
1239 local $to = $checked_timeout ? 10*60 : $header_timeout;
1240 local $sel = select($rmask, undef, undef, $to);
1241 if (!$sel) {
1242         if ($checked_timeout) {
1243                 print DEBUG "handle_request: exiting due to timeout of $to\n";
1244                 exit;
1245                 }
1246         else {
1247                 &http_error(400, "Timeout",
1248                             "Waited for that $to seconds for start of headers");
1249                 }
1250         }
1251 $checked_timeout++;
1252 print DEBUG "handle_request: passed timeout check\n";
1253
1254 # Read the HTTP request and headers
1255 local $origreqline = &read_line();
1256 ($reqline = $origreqline) =~ s/\r|\n//g;
1257 $method = $page = $request_uri = undef;
1258 print DEBUG "handle_request reqline=$reqline\n";
1259 if (!$reqline && (!$use_ssl || $checked_timeout > 1)) {
1260         # An empty request .. just close the connection
1261         print DEBUG "handle_request: rejecting empty request\n";
1262         return 0;
1263         }
1264 elsif ($reqline !~ /^(\S+)\s+(.*)\s+HTTP\/1\..$/) {
1265         print DEBUG "handle_request: invalid reqline=$reqline\n";
1266         if ($use_ssl) {
1267                 # This could be an http request when it should be https
1268                 $use_ssl = 0;
1269                 local $url = $config{'musthost'} ?
1270                                 "https://$config{'musthost'}:$port/" :
1271                                 "https://$host:$port/";
1272                 if ($config{'ssl_redirect'}) {
1273                         # Just re-direct to the correct URL
1274                         sleep(1);       # Give browser a change to finish
1275                                         # sending its request
1276                         &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
1277                         &write_data("Date: $datestr\r\n");
1278                         &write_data("Server: $config{'server'}\r\n");
1279                         &write_data("Location: $url\r\n");
1280                         &write_keep_alive(0);
1281                         &write_data("\r\n");
1282                         return 0;
1283                         }
1284                 else {
1285                         # Tell user the correct URL
1286                         &http_error(200, "Bad Request", "This web server is running in SSL mode. Try the URL <a href='$url'>$url</a> instead.<br>");
1287                         }
1288                 }
1289         elsif (ord(substr($reqline, 0, 1)) == 128 && !$use_ssl) {
1290                 # This could be an https request when it should be http ..
1291                 # need to fake a HTTP response
1292                 eval <<'EOF';
1293                         use Net::SSLeay;
1294                         eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
1295                         eval "Net::SSLeay::load_error_strings()";
1296                         $ssl_ctx = Net::SSLeay::CTX_new();
1297                         Net::SSLeay::CTX_use_RSAPrivateKey_file(
1298                                 $ssl_ctx, $config{'keyfile'},
1299                                 &Net::SSLeay::FILETYPE_PEM);
1300                         Net::SSLeay::CTX_use_certificate_file(
1301                                 $ssl_ctx,
1302                                 $config{'certfile'} || $config{'keyfile'},
1303                                 &Net::SSLeay::FILETYPE_PEM);
1304                         $ssl_con = Net::SSLeay::new($ssl_ctx);
1305                         pipe(SSLr, SSLw);
1306                         if (!fork()) {
1307                                 close(SSLr);
1308                                 select(SSLw); $| = 1; select(STDOUT);
1309                                 print SSLw $origreqline;
1310                                 local $buf;
1311                                 while(sysread(SOCK, $buf, 1) > 0) {
1312                                         print SSLw $buf;
1313                                         }
1314                                 close(SOCK);
1315                                 exit;
1316                                 }
1317                         close(SSLw);
1318                         Net::SSLeay::set_wfd($ssl_con, fileno(SOCK));
1319                         Net::SSLeay::set_rfd($ssl_con, fileno(SSLr));
1320                         Net::SSLeay::accept($ssl_con) || die "accept() failed";
1321                         $use_ssl = 1;
1322                         local $url = $config{'musthost'} ?
1323                                         "https://$config{'musthost'}:$port/" :
1324                                         "https://$host:$port/";
1325                         if ($config{'ssl_redirect'}) {
1326                                 # Just re-direct to the correct URL
1327                                 sleep(1);       # Give browser a change to
1328                                                 # finish sending its request
1329                                 &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
1330                                 &write_data("Date: $datestr\r\n");
1331                                 &write_data("Server: $config{'server'}\r\n");
1332                                 &write_data("Location: $url\r\n");
1333                                 &write_keep_alive(0);
1334                                 &write_data("\r\n");
1335                                 return 0;
1336                                 }
1337                         else {
1338                                 # Tell user the correct URL
1339                                 &http_error(200, "Bad Request", "This web server is not running in SSL mode. Try the URL <a href='$url'>$url</a> instead.<br>");
1340                                 }
1341 EOF
1342                 if ($@) {
1343                         &http_error(400, "Bad Request");
1344                         }
1345                 }
1346         else {
1347                 &http_error(400, "Bad Request");
1348                 }
1349         }
1350 $method = $1;
1351 $request_uri = $page = $2;
1352 %header = ();
1353 local $lastheader;
1354 while(1) {
1355         ($headline = &read_line()) =~ s/\r|\n//g;
1356         last if ($headline eq "");
1357         print DEBUG "handle_request: got headline $headline\n";
1358         if ($headline =~ /^(\S+):\s*(.*)$/) {
1359                 $header{$lastheader = lc($1)} = $2;
1360                 }
1361         elsif ($headline =~ /^\s+(.*)$/) {
1362                 $header{$lastheader} .= $headline;
1363                 }
1364         else {
1365                 &http_error(400, "Bad Header $headline");
1366                 }
1367         }
1368 if (defined($header{'host'})) {
1369         if ($header{'host'} =~ /^([^:]+):([0-9]+)$/) {
1370                 ($host, $port) = ($1, $2);
1371                 }
1372         else {
1373                 $host = $header{'host'};
1374                 }
1375         if ($config{'musthost'} && $host ne $config{'musthost'}) {
1376                 # Disallowed hostname used
1377                 &http_error(400, "Invalid HTTP hostname");
1378                 }
1379         }
1380 undef(%in);
1381 if ($page =~ /^([^\?]+)\?(.*)$/) {
1382         # There is some query string information
1383         $page = $1;
1384         $querystring = $2;
1385         print DEBUG "handle_request: querystring=$querystring\n";
1386         if ($querystring !~ /=/) {
1387                 $queryargs = $querystring;
1388                 $queryargs =~ s/\+/ /g;
1389                 $queryargs =~ s/%(..)/pack("c",hex($1))/ge;
1390                 $querystring = "";
1391                 }
1392         else {
1393                 # Parse query-string parameters
1394                 local @in = split(/\&/, $querystring);
1395                 foreach $i (@in) {
1396                         local ($k, $v) = split(/=/, $i, 2);
1397                         $k =~ s/\+/ /g; $k =~ s/%(..)/pack("c",hex($1))/ge;
1398                         $v =~ s/\+/ /g; $v =~ s/%(..)/pack("c",hex($1))/ge;
1399                         $in{$k} = $v;
1400                         }
1401                 }
1402         }
1403 $posted_data = undef;
1404 if ($method eq 'POST' &&
1405     $header{'content-type'} eq 'application/x-www-form-urlencoded') {
1406         # Read in posted query string information, up the configured maximum
1407         # post request length
1408         $clen = $header{"content-length"};
1409         $clen_read = $clen > $config{'max_post'} ? $config{'max_post'} : $clen;
1410         while(length($posted_data) < $clen_read) {
1411                 $buf = &read_data($clen_read - length($posted_data));
1412                 if (!length($buf)) {
1413                         &http_error(500, "Failed to read POST request");
1414                         }
1415                 chomp($posted_data);
1416                 $posted_data =~ s/\015$//mg;
1417                 $posted_data .= $buf;
1418                 }
1419         print DEBUG "clen_read=$clen_read clen=$clen posted_data=",length($posted_data),"\n";
1420         if ($clen_read != $clen && length($posted_data) > $clen) {
1421                 # If the client sent more data than we asked for, chop the
1422                 # rest off
1423                 $posted_data = substr($posted_data, 0, $clen);
1424                 }
1425         if (length($posted_data) > $clen) {
1426                 # When the client sent too much, delay so that it gets headers
1427                 sleep(3);
1428                 }
1429         if ($header{'user-agent'} =~ /MSIE/ &&
1430             $header{'user-agent'} !~ /Opera/i) {
1431                 # MSIE includes an extra newline in the data
1432                 $posted_data =~ s/\r|\n//g;
1433                 }
1434         local @in = split(/\&/, $posted_data);
1435         foreach $i (@in) {
1436                 local ($k, $v) = split(/=/, $i, 2);
1437                 #$v =~ s/\r|\n//g;
1438                 $k =~ s/\+/ /g; $k =~ s/%(..)/pack("c",hex($1))/ge;
1439                 $v =~ s/\+/ /g; $v =~ s/%(..)/pack("c",hex($1))/ge;
1440                 $in{$k} = $v;
1441                 }
1442         print DEBUG "handle_request: posted_data=$posted_data\n";
1443         }
1444
1445 # work out accepted encodings
1446 %acceptenc = map { $_, 1 } split(/,/, $header{'accept-encoding'});
1447
1448 # replace %XX sequences in page
1449 $page =~ s/%(..)/pack("c",hex($1))/ge;
1450
1451 # Check if the browser's user agent indicates a mobile device
1452 $mobile_device = &is_mobile_useragent($header{'user-agent'});
1453
1454 # Check if Host: header is for a mobile URL
1455 foreach my $m (@mobile_prefixes) {
1456         if ($header{'host'} =~ /^\Q$m\E/i) {
1457                 $mobile_device = 1;
1458                 }
1459         }
1460
1461 # check for the logout flag file, and if existant deny authentication
1462 if ($config{'logout'} && -r $config{'logout'}.$in{'miniserv_logout_id'}) {
1463         print DEBUG "handle_request: logout flag set\n";
1464         $deny_authentication++;
1465         open(LOGOUT, $config{'logout'}.$in{'miniserv_logout_id'});
1466         chop($count = <LOGOUT>);
1467         close(LOGOUT);
1468         $count--;
1469         if ($count > 0) {
1470                 open(LOGOUT, ">$config{'logout'}$in{'miniserv_logout_id'}");
1471                 print LOGOUT "$count\n";
1472                 close(LOGOUT);
1473                 }
1474         else {
1475                 unlink($config{'logout'}.$in{'miniserv_logout_id'});
1476                 }
1477         }
1478
1479 # check for any redirect for the requested URL
1480 foreach my $pfx (@strip_prefix) {
1481         my $l = length($pfx);
1482         if(length($page) >= $l &&
1483            substr($page,0,$l) eq $pfx) {
1484                 $page=substr($page,$l);
1485                 last;
1486                 }
1487         }
1488 $simple = &simplify_path($page, $bogus);
1489 $rpath = $simple;
1490 $rpath .= "&".$querystring if (defined($querystring));
1491 $redir = $redirect{$rpath};
1492 if (defined($redir)) {
1493         print DEBUG "handle_request: redir=$redir\n";
1494         &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
1495         &write_data("Date: $datestr\r\n");
1496         &write_data("Server: $config{'server'}\r\n");
1497         local $ssl = $use_ssl || $config{'inetd_ssl'};
1498         $portstr = $port == 80 && !$ssl ? "" :
1499                    $port == 443 && $ssl ? "" : ":$port";
1500         $prot = $ssl ? "https" : "http";
1501         &write_data("Location: $prot://$host$portstr$redir\r\n");
1502         &write_keep_alive(0);
1503         &write_data("\r\n");
1504         return 0;
1505         }
1506
1507 # Check for a DAV request
1508 $davpath = undef;
1509 foreach my $d (@davpaths) {
1510         if ($simple eq $d || $simple =~ /^\Q$d\E\//) {
1511                 $davpath = $d;
1512                 last;
1513                 }
1514         }
1515 if (!$davpath && ($method eq "SEARCH" || $method eq "PUT")) {
1516         &http_error(400, "Bad Request method $method");
1517         }
1518
1519 # Check for password if needed
1520 if ($config{'userfile'}) {
1521         print DEBUG "handle_request: Need authentication\n";
1522         $validated = 0;
1523         $blocked = 0;
1524
1525         # Session authentication is never used for connections by
1526         # another webmin server, or for specified pages, or for DAV, or XMLRPC,
1527         # or mobile browsers if requested.
1528         if ($header{'user-agent'} =~ /webmin/i ||
1529             $header{'user-agent'} =~ /$config{'agents_nosession'}/i ||
1530             $sessiononly{$simple} || $davpath ||
1531             $simple eq "/xmlrpc.cgi" ||
1532             $acptip eq $config{'host_nosession'} ||
1533             $mobile_device && $config{'mobile_nosession'}) {
1534                 print DEBUG "handle_request: Forcing HTTP authentication\n";
1535                 $config{'session'} = 0;
1536                 }
1537
1538         # Check for SSL authentication
1539         if ($use_ssl && $verified_client) {
1540                 $peername = Net::SSLeay::X509_NAME_oneline(
1541                                 Net::SSLeay::X509_get_subject_name(
1542                                         Net::SSLeay::get_peer_certificate(
1543                                                 $ssl_con)));
1544                 $u = &find_user_by_cert($peername);
1545                 if ($u) {
1546                         $authuser = $u;
1547                         $validated = 2;
1548                         }
1549                 if ($use_syslog && !$validated) {
1550                         syslog("crit", "%s",
1551                                "Unknown SSL certificate $peername");
1552                         }
1553                 }
1554
1555         if (!$validated && !$deny_authentication) {
1556                 # check for IP-based authentication
1557                 local $a;
1558                 foreach $a (keys %ipaccess) {
1559                         if ($acptip eq $a) {
1560                                 # It does! Auth as the user
1561                                 $validated = 3;
1562                                 $baseauthuser = $authuser =
1563                                         $ipaccess{$a};
1564                                 }
1565                         }
1566                 }
1567
1568         # Check for normal HTTP authentication
1569         if (!$validated && !$deny_authentication && !$config{'session'} &&
1570             $header{authorization} =~ /^basic\s+(\S+)$/i) {
1571                 # authorization given..
1572                 ($authuser, $authpass) = split(/:/, &b64decode($1), 2);
1573                 print DEBUG "handle_request: doing basic auth check authuser=$authuser authpass=$authpass\n";
1574                 local ($vu, $expired, $nonexist) =
1575                         &validate_user($authuser, $authpass, $host,
1576                                        $acptip, $port);
1577                 print DEBUG "handle_request: vu=$vu expired=$expired nonexist=$nonexist\n";
1578                 if ($vu && (!$expired || $config{'passwd_mode'} == 1)) {
1579                         $authuser = $vu;
1580                         $validated = 1;
1581                         }
1582                 else {
1583                         $validated = 0;
1584                         }
1585                 if ($use_syslog && !$validated) {
1586                         syslog("crit", "%s",
1587                                ($nonexist ? "Non-existent" :
1588                                 $expired ? "Expired" : "Invalid").
1589                                " login as $authuser from $acpthost");
1590                         }
1591                 if ($authuser =~ /\r|\n|\s/) {
1592                         &http_error(500, "Invalid username",
1593                                     "Username contains invalid characters");
1594                         }
1595                 if ($authpass =~ /\r|\n/) {
1596                         &http_error(500, "Invalid password",
1597                                     "Password contains invalid characters");
1598                         }
1599
1600                 if ($config{'passdelay'} && !$config{'inetd'} && $authuser) {
1601                         # check with main process for delay
1602                         print DEBUG "handle_request: about to ask for password delay\n";
1603                         print $PASSINw "delay $authuser $acptip $validated\n";
1604                         <$PASSOUTr> =~ /(\d+) (\d+)/;
1605                         $blocked = $2;
1606                         print DEBUG "handle_request: password delay $1 $2\n";
1607                         sleep($1);
1608                         }
1609                 }
1610
1611         # Check for a visit to the special session login page
1612         if ($config{'session'} && !$deny_authentication &&
1613             $page eq $config{'session_login'}) {
1614                 if ($in{'logout'} && $header{'cookie'} =~ /(^|\s)$sidname=([a-f0-9]+)/) {
1615                         # Logout clicked .. remove the session
1616                         local $sid = $2;
1617                         print $PASSINw "delete $sid\n";
1618                         local $louser = <$PASSOUTr>;
1619                         chop($louser);
1620                         $logout = 1;
1621                         $already_session_id = undef;
1622                         $authuser = $baseauthuser = undef;
1623                         if ($louser) {
1624                                 if ($use_syslog) {
1625                                         syslog("info", "%s", "Logout by $louser from $acpthost");
1626                                         }
1627                                 &run_logout_script($louser, $sid,
1628                                                    $acptip, $localip);
1629                                 &write_logout_utmp($louser, $actphost);
1630                                 }
1631                         }
1632                 else {
1633                         # Validate the user
1634                         if ($in{'user'} =~ /\r|\n|\s/) {
1635                                 &http_error(500, "Invalid username",
1636                                     "Username contains invalid characters");
1637                                 }
1638                         if ($in{'pass'} =~ /\r|\n/) {
1639                                 &http_error(500, "Invalid password",
1640                                     "Password contains invalid characters");
1641                                 }
1642
1643                         local ($vu, $expired, $nonexist) =
1644                                 &validate_user($in{'user'}, $in{'pass'}, $host,
1645                                                $acptip, $port);
1646                         local $hrv = &handle_login(
1647                                         $vu || $in{'user'}, $vu ? 1 : 0,
1648                                         $expired, $nonexist, $in{'pass'},
1649                                         $in{'notestingcookie'});
1650                         return $hrv if (defined($hrv));
1651                         }
1652                 }
1653
1654         # Check for a visit to the special PAM login page
1655         if ($config{'session'} && !$deny_authentication &&
1656             $use_pam && $config{'pam_conv'} && $page eq $config{'pam_login'} &&
1657             !$in{'restart'}) {
1658                 # A question has been entered .. submit it to the main process
1659                 print DEBUG "handle_request: Got call to $page ($in{'cid'})\n";
1660                 print DEBUG "handle_request: For PAM, authuser=$authuser\n";
1661                 if ($in{'answer'} =~ /\r|\n/ || $in{'cid'} =~ /\r|\n|\s/) {
1662                         &http_error(500, "Invalid response",
1663                             "Response contains invalid characters");
1664                         }
1665
1666                 if (!$in{'cid'}) {
1667                         # Start of a new conversation - answer must be username
1668                         $cid = &generate_random_id($in{'answer'});
1669                         print $PASSINw "pamstart $cid $host $in{'answer'}\n";
1670                         }
1671                 else {
1672                         # A response to a previous question
1673                         $cid = $in{'cid'};
1674                         print $PASSINw "pamanswer $cid $in{'answer'}\n";
1675                         }
1676
1677                 # Read back the response, and the next question (if any)
1678                 local $line = <$PASSOUTr>;
1679                 $line =~ s/\r|\n//g;
1680                 local ($rv, $question) = split(/\s+/, $line, 2);
1681                 if ($rv == 0) {
1682                         # Cannot login!
1683                         local $hrv = &handle_login(
1684                                 !$in{'cid'} && $in{'answer'} ? $in{'answer'}
1685                                                              : "unknown",
1686                                 0, 0, 1, undef);
1687                         return $hrv if (defined($hrv));
1688                         }
1689                 elsif ($rv == 1 || $rv == 3) {
1690                         # Another question .. force use of PAM CGI
1691                         $validated = 1;
1692                         $method = "GET";
1693                         $querystring .= "&cid=$cid&question=".
1694                                         &urlize($question);
1695                         $querystring .= "&password=1" if ($rv == 3);
1696                         $queryargs = "";
1697                         $page = $config{'pam_login'};
1698                         $miniserv_internal = 1;
1699                         $logged_code = 401;
1700                         }
1701                 elsif ($rv == 2) {
1702                         # Got back a final ok or failure
1703                         local ($user, $ok, $expired, $nonexist) =
1704                                 split(/\s+/, $question);
1705                         local $hrv = &handle_login(
1706                                 $user, $ok, $expired, $nonexist, undef,
1707                                 $in{'notestingcookie'});
1708                         return $hrv if (defined($hrv));
1709                         }
1710                 elsif ($rv == 4) {
1711                         # A message from PAM .. tell the user
1712                         $validated = 1;
1713                         $method = "GET";
1714                         $querystring .= "&cid=$cid&message=".
1715                                         &urlize($question);
1716                         $queryargs = "";
1717                         $page = $config{'pam_login'};
1718                         $miniserv_internal = 1;
1719                         $logged_code = 401;
1720                         }
1721                 }
1722
1723         # Check for a visit to the special password change page
1724         if ($config{'session'} && !$deny_authentication &&
1725             $page eq $config{'password_change'} && !$validated) {
1726                 # Just let this slide ..
1727                 $validated = 1;
1728                 $miniserv_internal = 3;
1729                 }
1730
1731         # Check for an existing session
1732         if ($config{'session'} && !$validated) {
1733                 if ($already_session_id) {
1734                         $session_id = $already_session_id;
1735                         $authuser = $already_authuser;
1736                         $validated = 1;
1737                         }
1738                 elsif (!$deny_authentication &&
1739                        $header{'cookie'} =~ /(^|\s)$sidname=([a-f0-9]+)/) {
1740                         # Try all session cookies
1741                         local $cookie = $header{'cookie'};
1742                         while($cookie =~ s/(^|\s)$sidname=([a-f0-9]+)//) {
1743                                 $session_id = $2;
1744                                 local $notimeout =
1745                                         $in{'webmin_notimeout'} ? 1 : 0;
1746                                 print $PASSINw "verify $session_id $notimeout\n";
1747                                 <$PASSOUTr> =~ /(\d+)\s+(\S+)/;
1748                                 if ($1 == 2) {
1749                                         # Valid session continuation
1750                                         $validated = 1;
1751                                         $authuser = $2;
1752                                         $already_authuser = $authuser;
1753                                         $timed_out = undef;
1754                                         last;
1755                                         }
1756                                 elsif ($1 == 1) {
1757                                         # Session timed out
1758                                         $timed_out = $2;
1759                                         }
1760                                 else {
1761                                         # Invalid session ID .. don't set
1762                                         # verified flag
1763                                         }
1764                                 }
1765                         }
1766                 }
1767
1768         # Check for local authentication
1769         if ($localauth_user && !$header{'x-forwarded-for'} && !$header{'via'}) {
1770                 my $luser = &get_user_details($localauth_user);
1771                 if ($luser) {
1772                         # Local user exists in webmin users file
1773                         $validated = 1;
1774                         $authuser = $localauth_user;
1775                         }
1776                 else {
1777                         # Check if local user is allowed by unixauth
1778                         local @can = &can_user_login($localauth_user,
1779                                                      undef, $host);
1780                         if ($can[0]) {
1781                                 $validated = 2;
1782                                 $authuser = $localauth_user;
1783                                 }
1784                         else {
1785                                 $localauth_user = undef;
1786                                 }
1787                         }
1788                 }
1789
1790         if (!$validated) {
1791                 # Check if this path allows anonymous access
1792                 local $a;
1793                 foreach $a (keys %anonymous) {
1794                         if (substr($simple, 0, length($a)) eq $a) {
1795                                 # It does! Auth as the user, if IP access
1796                                 # control allows him.
1797                                 if (&check_user_ip($anonymous{$a}) &&
1798                                     &check_user_time($anonymous{$a})) {
1799                                         $validated = 3;
1800                                         $baseauthuser = $authuser =
1801                                                 $anonymous{$a};
1802                                         }
1803                                 }
1804                         }
1805                 }
1806
1807         if (!$validated) {
1808                 # Check if this path allows unauthenticated access
1809                 local ($u, $unauth);
1810                 foreach $u (@unauth) {
1811                         $unauth++ if ($simple =~ /$u/);
1812                         }
1813                 if (!$bogus && $unauth) {
1814                         # Unauthenticated directory or file request - approve it
1815                         $validated = 4;
1816                         $baseauthuser = $authuser = undef;
1817                         }
1818                 }
1819
1820         if (!$validated) {
1821                 if ($blocked == 0) {
1822                         # No password given.. ask
1823                         if ($config{'pam_conv'} && $use_pam) {
1824                                 # Force CGI for PAM question, starting with
1825                                 # the username which is always needed
1826                                 $validated = 1;
1827                                 $method = "GET";
1828                                 $querystring .= "&initial=1&question=".
1829                                                 &urlize("Username");
1830                                 $querystring .= "&failed=$failed_user" if ($failed_user);
1831                                 $querystring .= "&timed_out=$timed_out" if ($timed_out);
1832                                 $queryargs = "";
1833                                 $page = $config{'pam_login'};
1834                                 $miniserv_internal = 1;
1835                                 $logged_code = 401;
1836                                 }
1837                         elsif ($config{'session'}) {
1838                                 # Force CGI for session login
1839                                 $validated = 1;
1840                                 if ($logout) {
1841                                         $querystring .= "&logout=1&page=/";
1842                                         }
1843                                 else {
1844                                         # Re-direct to current module only
1845                                         local $rpage = $request_uri;
1846                                         if (!$config{'loginkeeppage'}) {
1847                                                 $rpage =~ s/\?.*$//;
1848                                                 $rpage =~ s/[^\/]+$//
1849                                                 }
1850                                         $querystring = "page=".&urlize($rpage);
1851                                         }
1852                                 $method = "GET";
1853                                 $querystring .= "&failed=$failed_user" if ($failed_user);
1854                                 $querystring .= "&timed_out=$timed_out" if ($timed_out);
1855                                 $queryargs = "";
1856                                 $page = $config{'session_login'};
1857                                 $miniserv_internal = 1;
1858                                 $logged_code = 401;
1859                                 }
1860                         else {
1861                                 # Ask for login with HTTP authentication
1862                                 &write_data("HTTP/1.0 401 Unauthorized\r\n");
1863                                 &write_data("Date: $datestr\r\n");
1864                                 &write_data("Server: $config{'server'}\r\n");
1865                                 &write_data("WWW-authenticate: Basic ".
1866                                            "realm=\"$config{'realm'}\"\r\n");
1867                                 &write_keep_alive(0);
1868                                 &write_data("Content-type: text/html\r\n");
1869                                 &write_data("\r\n");
1870                                 &reset_byte_count();
1871                                 &write_data("<html>\n");
1872                                 &write_data("<head><title>Unauthorized</title></head>\n");
1873                                 &write_data("<body><h1>Unauthorized</h1>\n");
1874                                 &write_data("A password is required to access this\n");
1875                                 &write_data("web server. Please try again. <p>\n");
1876                                 &write_data("</body></html>\n");
1877                                 &log_request($acpthost, undef, $reqline, 401, &byte_count());
1878                                 return 0;
1879                                 }
1880                         }
1881                 elsif ($blocked == 1) {
1882                         # when the host has been blocked, give it an error
1883                         &http_error(403, "Access denied for $acptip. The host ".
1884                                          "has been blocked because of too ".
1885                                          "many authentication failures.");
1886                         }
1887                 elsif ($blocked == 2) {
1888                         # when the user has been blocked, give it an error
1889                         &http_error(403, "Access denied. The user ".
1890                                          "has been blocked because of too ".
1891                                          "many authentication failures.");
1892                         }
1893                 }
1894         else {
1895                 # Get the real Webmin username
1896                 local @can = &can_user_login($authuser, undef, $host);
1897                 $baseauthuser = $can[3] || $authuser;
1898
1899                 if ($config{'remoteuser'} && !$< && $validated) {
1900                         # Switch to the UID of the remote user (if he exists)
1901                         local @u = getpwnam($authuser);
1902                         if (@u && $< != $u[2]) {
1903                                 $( = $u[3]; $) = "$u[3] $u[3]";
1904                                 ($>, $<) = ($u[2], $u[2]);
1905                                 }
1906                         else {
1907                                 &http_error(500, "Unix user $authuser does not exist");
1908                                 return 0;
1909                                 }
1910                         }
1911                 }
1912
1913         # Check per-user IP access control
1914         if (!&check_user_ip($baseauthuser)) {
1915                 &http_error(403, "Access denied for $acptip for $baseauthuser");
1916                 return 0;
1917                 }
1918
1919         # Check per-user allowed times
1920         if (!&check_user_time($baseauthuser)) {
1921                 &http_error(403, "Access denied at the current time");
1922                 return 0;
1923                 }
1924         }
1925 $uinfo = &get_user_details($baseauthuser);
1926
1927 # Validate the path, and convert to canonical form
1928 rerun:
1929 $simple = &simplify_path($page, $bogus);
1930 print DEBUG "handle_request: page=$page simple=$simple\n";
1931 if ($bogus) {
1932         &http_error(400, "Invalid path");
1933         }
1934
1935 # Check for a DAV request
1936 if ($davpath) {
1937         return &handle_dav_request($davpath);
1938         }
1939
1940 # Work out the active theme(s)
1941 local $preroots = $mobile_device && defined($config{'mobile_preroot'}) ?
1942                         $config{'mobile_preroot'} :
1943                  $authuser && defined($config{'preroot_'.$authuser}) ?
1944                         $config{'preroot_'.$authuser} :
1945                  $uinfo && defined($uinfo->{'preroot'}) ?
1946                         $uinfo->{'preroot'} :
1947                         $config{'preroot'};
1948 local @preroots = reverse(split(/\s+/, $preroots));
1949
1950 # Canonicalize the directories
1951 foreach my $preroot (@preroots) {
1952         # Always under the current webmin root
1953         $preroot =~ s/^.*\///g;
1954         $preroot = $roots[0].'/'.$preroot;
1955         }
1956
1957 # Look in the theme root directories first
1958 local ($full, @stfull);
1959 $foundroot = undef;
1960 foreach my $preroot (@preroots) {
1961         $is_directory = 1;
1962         $sofar = "";
1963         $full = $preroot.$sofar;
1964         $scriptname = $simple;
1965         foreach $b (split(/\//, $simple)) {
1966                 if ($b ne "") { $sofar .= "/$b"; }
1967                 $full = $preroot.$sofar;
1968                 @stfull = stat($full);
1969                 if (!@stfull) { undef($full); last; }
1970
1971                 # Check if this is a directory
1972                 if (-d _) {
1973                         # It is.. go on parsing
1974                         $is_directory = 1;
1975                         next;
1976                         }
1977                 else {
1978                         $is_directory = 0;
1979                         }
1980
1981                 # Check if this is a CGI program
1982                 if (&get_type($full) eq "internal/cgi") {
1983                         $pathinfo = substr($simple, length($sofar));
1984                         $pathinfo .= "/" if ($page =~ /\/$/);
1985                         $scriptname = $sofar;
1986                         last;
1987                         }
1988                 }
1989
1990         # Don't stop at a directory unless this is the last theme, which
1991         # is the 'real' one that provides the .cgi scripts
1992         if ($is_directory && $preroot ne $preroots[$#preroots]) {
1993                 next;
1994                 }
1995
1996         if ($full) {
1997                 # Found it!
1998                 if ($sofar eq '') {
1999                         $cgi_pwd = $roots[0];
2000                         }
2001                 elsif ($is_directory) {
2002                         $cgi_pwd = "$roots[0]$sofar";
2003                         }
2004                 else {
2005                         "$roots[0]$sofar" =~ /^(.*\/)[^\/]+$/;
2006                         $cgi_pwd = $1;
2007                         }
2008                 $foundroot = $preroot;
2009                 if ($is_directory) {
2010                         # Check for index files in the directory
2011                         local $foundidx;
2012                         foreach $idx (split(/\s+/, $config{"index_docs"})) {
2013                                 $idxfull = "$full/$idx";
2014                                 local @stidxfull = stat($idxfull);
2015                                 if (-r _ && !-d _) {
2016                                         $full = $idxfull;
2017                                         @stfull = @stidxfull;
2018                                         $is_directory = 0;
2019                                         $scriptname .= "/"
2020                                                 if ($scriptname ne "/");
2021                                         $foundidx++;
2022                                         last;
2023                                         }
2024                                 }
2025                         @stfull = stat($full) if (!$foundidx);
2026                         }
2027                 }
2028         last if ($foundroot);
2029         }
2030 print DEBUG "handle_request: initial full=$full\n";
2031
2032 # Look in the real root directories, stopping when we find a file or directory
2033 if (!$full || $is_directory) {
2034         ROOT: foreach $root (@roots) {
2035                 $sofar = "";
2036                 $full = $root.$sofar;
2037                 $scriptname = $simple;
2038                 foreach $b ($simple eq "/" ? ( "" ) : split(/\//, $simple)) {
2039                         if ($b ne "") { $sofar .= "/$b"; }
2040                         $full = $root.$sofar;
2041                         @stfull = stat($full);
2042                         if (!@stfull) {
2043                                 next ROOT;
2044                                 }
2045
2046                         # Check if this is a directory
2047                         if (-d _) {
2048                                 # It is.. go on parsing
2049                                 next;
2050                                 }
2051
2052                         # Check if this is a CGI program
2053                         if (&get_type($full) eq "internal/cgi") {
2054                                 $pathinfo = substr($simple, length($sofar));
2055                                 $pathinfo .= "/" if ($page =~ /\/$/);
2056                                 $scriptname = $sofar;
2057                                 last;
2058                                 }
2059                         }
2060
2061                 # Run CGI in the same directory as whatever file
2062                 # was requested
2063                 $full =~ /^(.*\/)[^\/]+$/; $cgi_pwd = $1;
2064
2065                 if (-e $full) {
2066                         # Found something!
2067                         $realroot = $root;
2068                         $foundroot = $root;
2069                         last;
2070                         }
2071                 }
2072         if (!@stfull) { &http_error(404, "File not found"); }
2073         }
2074 print DEBUG "handle_request: full=$full\n";
2075 @stfull = stat($full) if (!@stfull);
2076
2077 # check filename against denyfile regexp
2078 local $denyfile = $config{'denyfile'};
2079 if ($denyfile && $full =~ /$denyfile/) {
2080         &http_error(403, "Access denied to $page");
2081         return 0;
2082         }
2083
2084 # Reached the end of the path OK.. see what we've got
2085 if (-d _) {
2086         # See if the URL ends with a / as it should
2087         print DEBUG "handle_request: found a directory\n";
2088         if ($page !~ /\/$/) {
2089                 # It doesn't.. redirect
2090                 &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
2091                 $ssl = $use_ssl || $config{'inetd_ssl'};
2092                 $portstr = $port == 80 && !$ssl ? "" :
2093                            $port == 443 && $ssl ? "" : ":$port";
2094                 &write_data("Date: $datestr\r\n");
2095                 &write_data("Server: $config{server}\r\n");
2096                 $prot = $ssl ? "https" : "http";
2097                 &write_data("Location: $prot://$host$portstr$page/\r\n");
2098                 &write_keep_alive(0);
2099                 &write_data("\r\n");
2100                 &log_request($acpthost, $authuser, $reqline, 302, 0);
2101                 return 0;
2102                 }
2103         # A directory.. check for index files
2104         local $foundidx;
2105         foreach $idx (split(/\s+/, $config{"index_docs"})) {
2106                 $idxfull = "$full/$idx";
2107                 @stidxfull = stat($idxfull);
2108                 if (-r _ && !-d _) {
2109                         $cgi_pwd = $full;
2110                         $full = $idxfull;
2111                         @stfull = @stidxfull;
2112                         $scriptname .= "/" if ($scriptname ne "/");
2113                         $foundidx++;
2114                         last;
2115                         }
2116                 }
2117         @stfull = stat($full) if (!$foundidx);
2118         }
2119 if (-d _) {
2120         # This is definately a directory.. list it
2121         print DEBUG "handle_request: listing directory\n";
2122         local $resp = "HTTP/1.0 $ok_code $ok_message\r\n".
2123                       "Date: $datestr\r\n".
2124                       "Server: $config{server}\r\n".
2125                       "Content-type: text/html\r\n";
2126         &write_data($resp);
2127         &write_keep_alive(0);
2128         &write_data("\r\n");
2129         &reset_byte_count();
2130         &write_data("<h1>Index of $simple</h1>\n");
2131         &write_data("<pre>\n");
2132         &write_data(sprintf "%-35.35s %-20.20s %-10.10s\n",
2133                         "Name", "Last Modified", "Size");
2134         &write_data("<hr>\n");
2135         opendir(DIR, $full);
2136         while($df = readdir(DIR)) {
2137                 if ($df =~ /^\./) { next; }
2138                 $fulldf = $full eq "/" ? $full.$df : $full."/".$df;
2139                 (@stbuf = stat($fulldf)) || next;
2140                 if (-d _) { $df .= "/"; }
2141                 @tm = localtime($stbuf[9]);
2142                 $fdate = sprintf "%2.2d/%2.2d/%4.4d %2.2d:%2.2d:%2.2d",
2143                                 $tm[3],$tm[4]+1,$tm[5]+1900,
2144                                 $tm[0],$tm[1],$tm[2];
2145                 $len = length($df); $rest = " "x(35-$len);
2146                 &write_data(sprintf
2147                  "<a href=\"%s\">%-${len}.${len}s</a>$rest %-20.20s %-10.10s\n",
2148                  $df, $df, $fdate, $stbuf[7]);
2149                 }
2150         closedir(DIR);
2151         &log_request($acpthost, $authuser, $reqline, $ok_code, &byte_count());
2152         return 0;
2153         }
2154
2155 # CGI or normal file
2156 local $rv;
2157 if (&get_type($full) eq "internal/cgi" && $validated != 4) {
2158         # A CGI program to execute
2159         print DEBUG "handle_request: executing CGI\n";
2160         $envtz = $ENV{"TZ"};
2161         $envuser = $ENV{"USER"};
2162         $envpath = $ENV{"PATH"};
2163         $envlang = $ENV{"LANG"};
2164         $envroot = $ENV{"SystemRoot"};
2165         $envperllib = $ENV{'PERLLIB'};
2166         foreach my $k (keys %ENV) {
2167                 delete($ENV{$k});
2168                 }
2169         $ENV{"PATH"} = $envpath if ($envpath);
2170         $ENV{"TZ"} = $envtz if ($envtz);
2171         $ENV{"USER"} = $envuser if ($envuser);
2172         $ENV{"OLD_LANG"} = $envlang if ($envlang);
2173         $ENV{"SystemRoot"} = $envroot if ($envroot);
2174         $ENV{'PERLLIB'} = $envperllib if ($envperllib);
2175         $ENV{"HOME"} = $user_homedir;
2176         $ENV{"SERVER_SOFTWARE"} = $config{"server"};
2177         $ENV{"SERVER_NAME"} = $host;
2178         $ENV{"SERVER_ADMIN"} = $config{"email"};
2179         $ENV{"SERVER_ROOT"} = $roots[0];
2180         $ENV{"SERVER_REALROOT"} = $realroot;
2181         $ENV{"SERVER_PORT"} = $port;
2182         $ENV{"REMOTE_HOST"} = $acpthost;
2183         $ENV{"REMOTE_ADDR"} = $acptip;
2184         $ENV{"REMOTE_ADDR_PROTOCOL"} = $ipv6 ? 6 : 4;
2185         $ENV{"REMOTE_USER"} = $authuser;
2186         $ENV{"BASE_REMOTE_USER"} = $authuser ne $baseauthuser ?
2187                                         $baseauthuser : undef;
2188         $ENV{"REMOTE_PASS"} = $authpass if (defined($authpass) &&
2189                                             $config{'pass_password'});
2190         if ($uinfo && $uinfo->{'proto'}) {
2191                 $ENV{"REMOTE_USER_PROTO"} = $uinfo->{'proto'};
2192                 $ENV{"REMOTE_USER_ID"} = $uinfo->{'id'};
2193                 }
2194         print DEBUG "REMOTE_USER = ",$ENV{"REMOTE_USER"},"\n";
2195         print DEBUG "BASE_REMOTE_USER = ",$ENV{"BASE_REMOTE_USER"},"\n";
2196         print DEBUG "proto=$uinfo->{'proto'} id=$uinfo->{'id'}\n" if ($uinfo);
2197         $ENV{"SSL_USER"} = $peername if ($validated == 2);
2198         $ENV{"ANONYMOUS_USER"} = "1" if ($validated == 3 || $validated == 4);
2199         $ENV{"DOCUMENT_ROOT"} = $roots[0];
2200         $ENV{"DOCUMENT_REALROOT"} = $realroot;
2201         $ENV{"GATEWAY_INTERFACE"} = "CGI/1.1";
2202         $ENV{"SERVER_PROTOCOL"} = "HTTP/1.0";
2203         $ENV{"REQUEST_METHOD"} = $method;
2204         $ENV{"SCRIPT_NAME"} = $scriptname;
2205         $ENV{"SCRIPT_FILENAME"} = $full;
2206         $ENV{"REQUEST_URI"} = $request_uri;
2207         $ENV{"PATH_INFO"} = $pathinfo;
2208         if ($pathinfo) {
2209                 $ENV{"PATH_TRANSLATED"} = "$roots[0]$pathinfo";
2210                 $ENV{"PATH_REALTRANSLATED"} = "$realroot$pathinfo";
2211                 }
2212         $ENV{"QUERY_STRING"} = $querystring;
2213         $ENV{"MINISERV_CONFIG"} = $config_file;
2214         $ENV{"HTTPS"} = "ON" if ($use_ssl || $config{'inetd_ssl'});
2215         $ENV{"MINISERV_PID"} = $miniserv_main_pid;
2216         $ENV{"SESSION_ID"} = $session_id if ($session_id);
2217         $ENV{"LOCAL_USER"} = $localauth_user if ($localauth_user);
2218         $ENV{"MINISERV_INTERNAL"} = $miniserv_internal if ($miniserv_internal);
2219         if (defined($header{"content-length"})) {
2220                 $ENV{"CONTENT_LENGTH"} = $header{"content-length"};
2221                 }
2222         if (defined($header{"content-type"})) {
2223                 $ENV{"CONTENT_TYPE"} = $header{"content-type"};
2224                 }
2225         foreach $h (keys %header) {
2226                 ($hname = $h) =~ tr/a-z/A-Z/;
2227                 $hname =~ s/\-/_/g;
2228                 $ENV{"HTTP_$hname"} = $header{$h};
2229                 }
2230         $ENV{"PWD"} = $cgi_pwd;
2231         foreach $k (keys %config) {
2232                 if ($k =~ /^env_(\S+)$/) {
2233                         $ENV{$1} = $config{$k};
2234                         }
2235                 }
2236         delete($ENV{'HTTP_AUTHORIZATION'});
2237         $ENV{'HTTP_COOKIE'} =~ s/;?\s*$sidname=([a-f0-9]+)//;
2238         $ENV{'MOBILE_DEVICE'} = 1 if ($mobile_device);
2239
2240         # Check if the CGI can be handled internally
2241         open(CGI, $full);
2242         local $first = <CGI>;
2243         close(CGI);
2244         $first =~ s/[#!\r\n]//g;
2245         $nph_script = ($full =~ /\/nph-([^\/]+)$/);
2246         seek(STDERR, 0, 2);
2247         if (!$config{'forkcgis'} &&
2248             ($first eq $perl_path || $first eq $linked_perl_path) &&
2249               $] >= 5.004 ||
2250             $config{'internalcgis'}) {
2251                 # setup environment for eval
2252                 chdir($ENV{"PWD"});
2253                 @ARGV = split(/\s+/, $queryargs);
2254                 $0 = $full;
2255                 if ($posted_data) {
2256                         # Already read the post input
2257                         $postinput = $posted_data;
2258                         }
2259                 $clen = $header{"content-length"};
2260                 $SIG{'CHLD'} = 'DEFAULT';
2261                 eval {
2262                         # Have SOCK closed if the perl exec's something
2263                         use Fcntl;
2264                         fcntl(SOCK, F_SETFD, FD_CLOEXEC);
2265                         };
2266                 #shutdown(SOCK, 0);
2267
2268                 if ($config{'log'}) {
2269                         open(MINISERVLOG, ">>$config{'logfile'}");
2270                         if ($config{'logperms'}) {
2271                                 chmod(oct($config{'logperms'}),
2272                                       $config{'logfile'});
2273                                 }
2274                         else {
2275                                 chmod(0600, $config{'logfile'});
2276                                 }
2277                         }
2278                 $doing_cgi_eval = 1;
2279                 $main_process_id = $$;
2280                 $pkg = "main";
2281                 if ($full =~ /^\Q$foundroot\E\/([^\/]+)\//) {
2282                         # Eval in package from Webmin module name
2283                         $pkg = $1;
2284                         $pkg =~ s/[^A-Za-z0-9]/_/g;
2285                         }
2286                 eval "
2287                         \%pkg::ENV = \%ENV;
2288                         package $pkg;
2289                         tie(*STDOUT, 'miniserv');
2290                         tie(*STDIN, 'miniserv');
2291                         do \$miniserv::full;
2292                         die \$@ if (\$@);
2293                         ";
2294                 $doing_cgi_eval = 0;
2295                 if ($@) {
2296                         # Error in perl!
2297                         &http_error(500, "Perl execution failed",
2298                                     $config{'noshowstderr'} ? undef : $@);
2299                         }
2300                 elsif (!$doneheaders && !$nph_script) {
2301                         &http_error(500, "Missing Headers");
2302                         }
2303                 $rv = 0;
2304                 }
2305         else {
2306                 $infile = undef;
2307                 if (!$on_windows) {
2308                         # fork the process that actually executes the CGI
2309                         pipe(CGIINr, CGIINw);
2310                         pipe(CGIOUTr, CGIOUTw);
2311                         pipe(CGIERRr, CGIERRw);
2312                         if (!($cgipid = fork())) {
2313                                 @execargs = ( $full, split(/\s+/, $queryargs) );
2314                                 chdir($ENV{"PWD"});
2315                                 close(SOCK);
2316                                 open(STDIN, "<&CGIINr");
2317                                 open(STDOUT, ">&CGIOUTw");
2318                                 open(STDERR, ">&CGIERRw");
2319                                 close(CGIINw); close(CGIOUTr); close(CGIERRr);
2320                                 exec(@execargs) ||
2321                                         die "Failed to exec $full : $!\n";
2322                                 exit(0);
2323                                 }
2324                         close(CGIINr); close(CGIOUTw); close(CGIERRw);
2325                         }
2326                 else {
2327                         # write CGI input to a temp file
2328                         $infile = "$config{'tempbase'}.$$";
2329                         open(CGIINw, ">$infile");
2330                         # NOT binary mode, as CGIs don't read in it!
2331                         }
2332
2333                 # send post data
2334                 if ($posted_data) {
2335                         # already read the posted data
2336                         print CGIINw $posted_data;
2337                         }
2338                 $clen = $header{"content-length"};
2339                 if ($method eq "POST" && $clen_read < $clen) {
2340                         $SIG{'PIPE'} = 'IGNORE';
2341                         $got = $clen_read;
2342                         while($got < $clen) {
2343                                 $buf = &read_data($clen-$got);
2344                                 if (!length($buf)) {
2345                                         kill('TERM', $cgipid);
2346                                         unlink($infile) if ($infile);
2347                                         &http_error(500, "Failed to read ".
2348                                                          "POST request");
2349                                         }
2350                                 $got += length($buf);
2351                                 local ($wrote) = (print CGIINw $buf);
2352                                 last if (!$wrote);
2353                                 }
2354                         # If the CGI terminated early, we still need to read
2355                         # from the browser and throw away
2356                         while($got < $clen) {
2357                                 $buf = &read_data($clen-$got);
2358                                 if (!length($buf)) {
2359                                         kill('TERM', $cgipid);
2360                                         unlink($infile) if ($infile);
2361                                         &http_error(500, "Failed to read ".
2362                                                          "POST request");
2363                                         }
2364                                 $got += length($buf);
2365                                 }
2366                         $SIG{'PIPE'} = 'DEFAULT';
2367                         }
2368                 close(CGIINw);
2369                 shutdown(SOCK, 0);
2370
2371                 if ($on_windows) {
2372                         # Run the CGI program, and feed it input
2373                         chdir($ENV{"PWD"});
2374                         local $qqueryargs = join(" ", map { "\"$_\"" }
2375                                                  split(/\s+/, $queryargs));
2376                         if ($first =~ /(perl|perl.exe)$/i) {
2377                                 # On Windows, run with Perl
2378                                 open(CGIOUTr, "$perl_path \"$full\" $qqueryargs <$infile |");
2379                                 }
2380                         else {
2381                                 open(CGIOUTr, "\"$full\" $qqueryargs <$infile |");
2382                                 }
2383                         binmode(CGIOUTr);
2384                         }
2385
2386                 if (!$nph_script) {
2387                         # read back cgi headers
2388                         select(CGIOUTr); $|=1; select(STDOUT);
2389                         $got_blank = 0;
2390                         while(1) {
2391                                 $line = <CGIOUTr>;
2392                                 $line =~ s/\r|\n//g;
2393                                 if ($line eq "") {
2394                                         if ($got_blank || %cgiheader) { last; }
2395                                         $got_blank++;
2396                                         next;
2397                                         }
2398                                 if ($line !~ /^(\S+):\s+(.*)$/) {
2399                                         $errs = &read_errors(CGIERRr);
2400                                         close(CGIOUTr); close(CGIERRr);
2401                                         unlink($infile) if ($infile);
2402                                         &http_error(500, "Bad Header", $errs);
2403                                         }
2404                                 $cgiheader{lc($1)} = $2;
2405                                 push(@cgiheader, [ $1, $2 ]);
2406                                 }
2407                         if ($cgiheader{"location"}) {
2408                                 &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
2409                                 &write_data("Date: $datestr\r\n");
2410                                 &write_data("Server: $config{'server'}\r\n");
2411                                 &write_keep_alive(0);
2412                                 # ignore the rest of the output. This is a hack,
2413                                 # but is necessary for IE in some cases :(
2414                                 close(CGIOUTr); close(CGIERRr);
2415                                 }
2416                         elsif ($cgiheader{"content-type"} eq "") {
2417                                 close(CGIOUTr); close(CGIERRr);
2418                                 unlink($infile) if ($infile);
2419                                 $errs = &read_errors(CGIERRr);
2420                                 &http_error(500, "Missing Content-Type Header",
2421                                     $config{'noshowstderr'} ? undef : $errs);
2422                                 }
2423                         else {
2424                                 &write_data("HTTP/1.0 $ok_code $ok_message\r\n");
2425                                 &write_data("Date: $datestr\r\n");
2426                                 &write_data("Server: $config{'server'}\r\n");
2427                                 &write_keep_alive(0);
2428                                 }
2429                         foreach $h (@cgiheader) {
2430                                 &write_data("$h->[0]: $h->[1]\r\n");
2431                                 }
2432                         &write_data("\r\n");
2433                         }
2434                 &reset_byte_count();
2435                 while($line = <CGIOUTr>) {
2436                         &write_data($line);
2437                         }
2438                 close(CGIOUTr);
2439                 close(CGIERRr);
2440                 unlink($infile) if ($infile);
2441                 $rv = 0;
2442                 }
2443         }
2444 else {
2445         # A file to output
2446         print DEBUG "handle_request: outputting file $full\n";
2447         $gzfile = $full.".gz";
2448         $gzipped = 0;
2449         if ($config{'gzip'} ne '0' && -r $gzfile && $acceptenc{'gzip'}) {
2450                 # Using gzipped version
2451                 @stopen = stat($gzfile);
2452                 if ($stopen[9] >= $stfull[9] && open(FILE, $gzfile)) {
2453                         print DEBUG "handle_request: using gzipped $gzfile\n";
2454                         $gzipped = 1;
2455                         }
2456                 }
2457         if (!$gzipped) {
2458                 # Using original file
2459                 @stopen = @stfull;
2460                 open(FILE, $full) || &http_error(404, "Failed to open file");
2461                 }
2462         binmode(FILE);
2463
2464         # Build common headers
2465         local $resp = "HTTP/1.0 $ok_code $ok_message\r\n".
2466                       "Date: $datestr\r\n".
2467                       "Server: $config{server}\r\n".
2468                       "Content-type: ".&get_type($full)."\r\n".
2469                       "Last-Modified: ".&http_date($stopen[9])."\r\n".
2470                       "Expires: ".
2471                         &http_date(time()+&get_expires_time($simple))."\r\n";
2472
2473         if (!$gzipped && $use_gzip && $acceptenc{'gzip'} &&
2474             &should_gzip_file($full)) {
2475                 # Load and compress file, then output
2476                 print DEBUG "handle_request: outputting gzipped file $full\n";
2477                 open(FILE, $full) || &http_error(404, "Failed to open file");
2478                 {
2479                         local $/ = undef;
2480                         $data = <FILE>;
2481                 }
2482                 close(FILE);
2483                 @stopen = stat($file);
2484                 $data = Compress::Zlib::memGzip($data);
2485                 $resp .= "Content-length: ".length($data)."\r\n".
2486                          "Content-Encoding: gzip\r\n";
2487                 &write_data($resp);
2488                 $rv = &write_keep_alive();
2489                 &write_data("\r\n");
2490                 &reset_byte_count();
2491                 &write_data($data);
2492                 }
2493         else {
2494                 # Stream file output
2495                 $resp .= "Content-length: $stopen[7]\r\n";
2496                 $resp .= "Content-Encoding: gzip\r\n" if ($gzipped);
2497                 &write_data($resp);
2498                 $rv = &write_keep_alive();
2499                 &write_data("\r\n");
2500                 &reset_byte_count();
2501                 my $bufsize = $config{'bufsize'} || 1024;
2502                 while(read(FILE, $buf, $bufsize) > 0) {
2503                         &write_data($buf);
2504                         }
2505                 close(FILE);
2506                 }
2507         }
2508
2509 # log the request
2510 &log_request($acpthost, $authuser, $reqline,
2511              $logged_code ? $logged_code :
2512              $cgiheader{"location"} ? "302" : $ok_code, &byte_count());
2513 return $rv;
2514 }
2515
2516 # http_error(code, message, body, [dontexit])
2517 sub http_error
2518 {
2519 local $eh = $error_handler_recurse ? undef :
2520             $config{"error_handler_$_[0]"} ? $config{"error_handler_$_[0]"} :
2521             $config{'error_handler'} ? $config{'error_handler'} : undef;
2522 print DEBUG "http_error code=$_[0] message=$_[1] body=$_[2]\n";
2523 if ($eh) {
2524         # Call a CGI program for the error
2525         $page = "/$eh";
2526         $querystring = "code=$_[0]&message=".&urlize($_[1]).
2527                        "&body=".&urlize($_[2]);
2528         $error_handler_recurse++;
2529         $ok_code = $_[0];
2530         $ok_message = $_[1];
2531         goto rerun;
2532         }
2533 else {
2534         # Use the standard error message display
2535         &write_data("HTTP/1.0 $_[0] $_[1]\r\n");
2536         &write_data("Server: $config{server}\r\n");
2537         &write_data("Date: $datestr\r\n");
2538         &write_data("Content-type: text/html\r\n");
2539         &write_keep_alive(0);
2540         &write_data("\r\n");
2541         &reset_byte_count();
2542         &write_data("<h1>Error - $_[1]</h1>\n");
2543         if ($_[2]) {
2544                 &write_data("<pre>$_[2]</pre>\n");
2545                 }
2546         }
2547 &log_request($acpthost, $authuser, $reqline, $_[0], &byte_count())
2548         if ($reqline);
2549 &log_error($_[1], $_[2] ? " : $_[2]" : "");
2550 shutdown(SOCK, 1);
2551 exit if (!$_[3]);
2552 }
2553
2554 sub get_type
2555 {
2556 if ($_[0] =~ /\.([A-z0-9]+)$/) {
2557         $t = $mime{$1};
2558         if ($t ne "") {
2559                 return $t;
2560                 }
2561         }
2562 return "text/plain";
2563 }
2564
2565 # simplify_path(path, bogus)
2566 # Given a path, maybe containing stuff like ".." and "." convert it to a
2567 # clean, absolute form.
2568 sub simplify_path
2569 {
2570 local($dir, @bits, @fixedbits, $b);
2571 $dir = $_[0];
2572 $dir =~ s/\\/\//g;      # fix windows \ in path
2573 $dir =~ s/^\/+//g;
2574 $dir =~ s/\/+$//g;
2575 $dir =~ s/\0//g;        # remove null bytes
2576 @bits = split(/\/+/, $dir);
2577 @fixedbits = ();
2578 $_[1] = 0;
2579 foreach $b (@bits) {
2580         if ($b eq ".") {
2581                 # Do nothing..
2582                 }
2583         elsif ($b eq ".." || $b eq "...") {
2584                 # Remove last dir
2585                 if (scalar(@fixedbits) == 0) {
2586                         $_[1] = 1;
2587                         return "/";
2588                         }
2589                 pop(@fixedbits);
2590                 }
2591         else {
2592                 # Add dir to list
2593                 push(@fixedbits, $b);
2594                 }
2595         }
2596 return "/" . join('/', @fixedbits);
2597 }
2598
2599 # b64decode(string)
2600 # Converts a string from base64 format to normal
2601 sub b64decode
2602 {
2603     local($str) = $_[0];
2604     local($res);
2605     $str =~ tr|A-Za-z0-9+=/||cd;
2606     $str =~ s/=+$//;
2607     $str =~ tr|A-Za-z0-9+/| -_|;
2608     while ($str =~ /(.{1,60})/gs) {
2609         my $len = chr(32 + length($1)*3/4);
2610         $res .= unpack("u", $len . $1 );
2611     }
2612     return $res;
2613 }
2614
2615 # ip_match(remoteip, localip, [match]+)
2616 # Checks an IP address against a list of IPs, networks and networks/masks
2617 sub ip_match
2618 {
2619 local(@io, @mo, @ms, $i, $j, $hn, $needhn);
2620 @io = &check_ip6address($_[0]) ? split(/:/, $_[0])
2621                                : split(/\./, $_[0]);
2622 for($i=2; $i<@_; $i++) {
2623         $needhn++ if ($_[$i] =~ /^\*(\S+)$/);
2624         }
2625 if ($needhn && !defined($hn = $ip_match_cache{$_[0]})) {
2626         # Reverse-lookup hostname if any rules match based on it
2627         $hn = &to_hostname($_[0]);
2628         if (&check_ip6address($_[0])) {
2629                 $hn = "" if (&to_ip6address($hn) ne $_[0]);
2630                 }
2631         else {
2632                 $hn = "" if (&to_ipaddress($hn) ne $_[0]);
2633                 }
2634         $ip_match_cache{$_[0]} = $hn;
2635         }
2636 for($i=2; $i<@_; $i++) {
2637         local $mismatch = 0;
2638         if ($_[$i] =~ /^(\S+)\/(\d+)$/) {
2639                 # Convert CIDR to netmask format
2640                 $_[$i] = $1."/".&prefix_to_mask($2);
2641                 }
2642         if ($_[$i] =~ /^(\S+)\/(\S+)$/) {
2643                 # Compare with IPv4 network/mask
2644                 @mo = split(/\./, $1); @ms = split(/\./, $2);
2645                 for($j=0; $j<4; $j++) {
2646                         if ((int($io[$j]) & int($ms[$j])) != int($mo[$j])) {
2647                                 $mismatch = 1;
2648                                 }
2649                         }
2650                 }
2651         elsif ($_[$i] =~ /^\*(\S+)$/) {
2652                 # Compare with hostname regexp
2653                 $mismatch = 1 if ($hn !~ /$1$/);
2654                 }
2655         elsif ($_[$i] eq 'LOCAL' && &check_ipaddress($_[1])) {
2656                 # Compare with local IPv4 network
2657                 local @lo = split(/\./, $_[1]);
2658                 if ($lo[0] < 128) {
2659                         $mismatch = 1 if ($lo[0] != $io[0]);
2660                         }
2661                 elsif ($lo[0] < 192) {
2662                         $mismatch = 1 if ($lo[0] != $io[0] ||
2663                                           $lo[1] != $io[1]);
2664                         }
2665                 else {
2666                         $mismatch = 1 if ($lo[0] != $io[0] ||
2667                                           $lo[1] != $io[1] ||
2668                                           $lo[2] != $io[2]);
2669                         }
2670                 }
2671         elsif ($_[$i] eq 'LOCAL' && &check_ip6address($_[1])) {
2672                 # Compare with local IPv6 network, which is always first 4 words
2673                 local @lo = split(/:/, $_[1]);
2674                 for(my $i=0; $i<4; $i++) {
2675                         $mismatch = 1 if ($lo[$i] ne $io[$i]);
2676                         }
2677                 }
2678         elsif ($_[$i] =~ /^[0-9\.]+$/) {
2679                 # Compare with IPv4 address or network
2680                 @mo = split(/\./, $_[$i]);
2681                 while(@mo && !$mo[$#mo]) { pop(@mo); }
2682                 for($j=0; $j<@mo; $j++) {
2683                         if ($mo[$j] != $io[$j]) {
2684                                 $mismatch = 1;
2685                                 }
2686                         }
2687                 }
2688         elsif ($_[$i] =~ /^[a-f0-9:]+$/) {
2689                 # Compare with IPv6 address or network
2690                 @mo = split(/:/, $_[$i]);
2691                 while(@mo && !$mo[$#mo]) { pop(@mo); }
2692                 for($j=0; $j<@mo; $j++) {
2693                         if ($mo[$j] ne $io[$j]) {
2694                                 $mismatch = 1;
2695                                 }
2696                         }
2697                 }
2698         elsif ($_[$i] !~ /^[0-9\.]+$/) {
2699                 # Compare with hostname
2700                 $mismatch = 1 if ($_[0] ne &to_ipaddress($_[$i]));
2701                 }
2702         return 1 if (!$mismatch);
2703         }
2704 return 0;
2705 }
2706
2707 # users_match(&uinfo, user, ...)
2708 # Returns 1 if a user is in a list of users and groups
2709 sub users_match
2710 {
2711 local $uinfo = shift(@_);
2712 local $u;
2713 local @ginfo = getgrgid($uinfo->[3]);
2714 foreach $u (@_) {
2715         if ($u =~ /^\@(\S+)$/) {
2716                 return 1 if (&is_group_member($uinfo, $1));
2717                 }
2718         elsif ($u =~ /^(\d*)-(\d*)$/ && ($1 || $2)) {
2719                 return (!$1 || $uinfo[2] >= $1) &&
2720                        (!$2 || $uinfo[2] <= $2);
2721                 }
2722         else {
2723                 return 1 if ($u eq $uinfo->[0]);
2724                 }
2725         }
2726 return 0;
2727 }
2728
2729 # restart_miniserv()
2730 # Called when a SIGHUP is received to restart the web server. This is done
2731 # by exec()ing perl with the same command line as was originally used
2732 sub restart_miniserv
2733 {
2734 print STDERR "restarting miniserv\n";
2735 &log_error("Restarting");
2736 close(SOCK);
2737 &close_all_sockets();
2738 &close_all_pipes();
2739 dbmclose(%sessiondb);
2740 kill('KILL', $logclearer) if ($logclearer);
2741 kill('KILL', $extauth) if ($extauth);
2742 exec($perl_path, $miniserv_path, @miniserv_argv);
2743 die "Failed to restart miniserv with $perl_path $miniserv_path";
2744 }
2745
2746 sub trigger_restart
2747 {
2748 $need_restart = 1;
2749 }
2750
2751 sub trigger_reload
2752 {
2753 $need_reload = 1;
2754 }
2755
2756 # to_ipaddress(address, ...)
2757 sub to_ipaddress
2758 {
2759 local (@rv, $i);
2760 foreach $i (@_) {
2761         if ($i =~ /(\S+)\/(\S+)/ || $i =~ /^\*\S+$/ ||
2762             $i eq 'LOCAL' || $i =~ /^[0-9\.]+$/ || $i =~ /^[a-f0-9:]+$/) {
2763                 # A pattern or IP, not a hostname, so don't change
2764                 push(@rv, $i);
2765                 }
2766         else {
2767                 # Lookup IP address
2768                 push(@rv, join('.', unpack("CCCC", inet_aton($i))));
2769                 }
2770         }
2771 return wantarray ? @rv : $rv[0];
2772 }
2773
2774 # to_ip6address(address, ...)
2775 sub to_ip6address
2776 {
2777 local (@rv, $i);
2778 foreach $i (@_) {
2779         if ($i =~ /(\S+)\/(\S+)/ || $i =~ /^\*\S+$/ ||
2780             $i eq 'LOCAL' || $i =~ /^[0-9\.]+$/ || $i =~ /^[a-f0-9:]+$/) {
2781                 # A pattern, not a hostname, so don't change
2782                 push(@rv, $i);
2783                 }
2784         else {
2785                 # Lookup IPv6 address
2786                 local ($inaddr, $addr);
2787                 (undef, undef, undef, $inaddr) =
2788                     getaddrinfo($i, undef, Socket6::AF_INET6(), SOCK_STREAM);
2789                 if ($inaddr) {
2790                         push(@rv, undef);
2791                         }
2792                 else {
2793                         (undef, $addr) = unpack_sockaddr_in6($inaddr);
2794                         push(@rv, inet_ntop(Socket6::AF_INET6(), $addr));
2795                         }
2796                 }
2797         }
2798 return wantarray ? @rv : $rv[0];
2799 }
2800
2801 # to_hostname(ipv4|ipv6-address)
2802 # Reverse-resolves an IPv4 or 6 address to a hostname
2803 sub to_hostname
2804 {
2805 local ($addr) = @_;
2806 if (&check_ip6address($_[0])) {
2807         return gethostbyaddr(inet_pton(Socket6::AF_INET6(), $addr),
2808                              Socket6::AF_INET6());
2809         }
2810 else {
2811         return gethostbyaddr(inet_aton($addr), AF_INET);
2812         }
2813 }
2814
2815 # read_line(no-wait, no-limit)
2816 # Reads one line from SOCK or SSL
2817 sub read_line
2818 {
2819 local ($nowait, $nolimit) = @_;
2820 local($idx, $more, $rv);
2821 while(($idx = index($main::read_buffer, "\n")) < 0) {
2822         if (length($main::read_buffer) > 10000 && !$nolimit) {
2823                 &http_error(414, "Request too long",
2824                     "Received excessive line <pre>$main::read_buffer</pre>");
2825                 }
2826
2827         # need to read more..
2828         &wait_for_data_error() if (!$nowait);
2829         if ($use_ssl) {
2830                 $more = Net::SSLeay::read($ssl_con);
2831                 }
2832         else {
2833                 my $bufsize = $config{'bufsize'} || 1024;
2834                 local $ok = sysread(SOCK, $more, $bufsize);
2835                 $more = undef if ($ok <= 0);
2836                 }
2837         if ($more eq '') {
2838                 # end of the data
2839                 $rv = $main::read_buffer;
2840                 undef($main::read_buffer);
2841                 return $rv;
2842                 }
2843         $main::read_buffer .= $more;
2844         }
2845 $rv = substr($main::read_buffer, 0, $idx+1);
2846 $main::read_buffer = substr($main::read_buffer, $idx+1);
2847 return $rv;
2848 }
2849
2850 # read_data(length)
2851 # Reads up to some amount of data from SOCK or the SSL connection
2852 sub read_data
2853 {
2854 local ($rv);
2855 if (length($main::read_buffer)) {
2856         if (length($main::read_buffer) > $_[0]) {
2857                 # Return the first part of the buffer
2858                 $rv = substr($main::read_buffer, 0, $_[0]);
2859                 $main::read_buffer = substr($main::read_buffer, $_[0]);
2860                 return $rv;
2861                 }
2862         else {
2863                 # Return the whole buffer
2864                 $rv = $main::read_buffer;
2865                 undef($main::read_buffer);
2866                 return $rv;
2867                 }
2868         }
2869 elsif ($use_ssl) {
2870         # Call SSL read function
2871         return Net::SSLeay::read($ssl_con, $_[0]);
2872         }
2873 else {
2874         # Just do a normal read
2875         local $buf;
2876         sysread(SOCK, $buf, $_[0]) || return undef;
2877         return $buf;
2878         }
2879 }
2880
2881 # sysread_line(fh)
2882 # Read a line from a file handle, using sysread to get a byte at a time
2883 sub sysread_line
2884 {
2885 local ($fh) = @_;
2886 local $line;
2887 while(1) {
2888         local ($buf, $got);
2889         $got = sysread($fh, $buf, 1);
2890         last if ($got <= 0);
2891         $line .= $buf;
2892         last if ($buf eq "\n");
2893         }
2894 return $line;
2895 }
2896
2897 # wait_for_data(secs)
2898 # Waits at most the given amount of time for some data on SOCK, returning
2899 # 0 if not found, 1 if some arrived.
2900 sub wait_for_data
2901 {
2902 local $rmask;
2903 vec($rmask, fileno(SOCK), 1) = 1;
2904 local $got = select($rmask, undef, undef, $_[0]);
2905 return $got == 0 ? 0 : 1;
2906 }
2907
2908 # wait_for_data_error()
2909 # Waits 60 seconds for data on SOCK, and fails if none arrives
2910 sub wait_for_data_error
2911 {
2912 local $got = &wait_for_data(60);
2913 if (!$got) {
2914         &http_error(400, "Timeout",
2915                     "Waited more than 60 seconds for request data");
2916         }
2917 }
2918
2919 # write_data(data, ...)
2920 # Writes a string to SOCK or the SSL connection
2921 sub write_data
2922 {
2923 local $str = join("", @_);
2924 if ($use_ssl) {
2925         Net::SSLeay::write($ssl_con, $str);
2926         }
2927 else {
2928         syswrite(SOCK, $str, length($str));
2929         }
2930 # Intentionally introduce a small delay to avoid problems where IE reports
2931 # the page as empty / DNS failed when it get a large response too quickly!
2932 select(undef, undef, undef, .01) if ($write_data_count%10 == 0);
2933 $write_data_count += length($str);
2934 }
2935
2936 # reset_byte_count()
2937 sub reset_byte_count { $write_data_count = 0; }
2938
2939 # byte_count()
2940 sub byte_count { return $write_data_count; }
2941
2942 # log_request(hostname, user, request, code, bytes)
2943 sub log_request
2944 {
2945 if ($config{'log'}) {
2946         local ($user, $ident, $headers);
2947         if ($config{'logident'}) {
2948                 # add support for rfc1413 identity checking here
2949                 }
2950         else { $ident = "-"; }
2951         $user = $_[1] ? $_[1] : "-";
2952         local $dstr = &make_datestr();
2953         if (fileno(MINISERVLOG)) {
2954                 seek(MINISERVLOG, 0, 2);
2955                 }
2956         else {
2957                 open(MINISERVLOG, ">>$config{'logfile'}");
2958                 chmod(0600, $config{'logfile'});
2959                 }
2960         if (defined($config{'logheaders'})) {
2961                 foreach $h (split(/\s+/, $config{'logheaders'})) {
2962                         $headers .= " $h=\"$header{$h}\"";
2963                         }
2964                 }
2965         elsif ($config{'logclf'}) {
2966                 $headers = " \"$header{'referer'}\" \"$header{'user-agent'}\"";
2967                 }
2968         else {
2969                 $headers = "";
2970                 }
2971         print MINISERVLOG "$_[0] $ident $user [$dstr] \"$_[2]\" ",
2972                           "$_[3] $_[4]$headers\n";
2973         close(MINISERVLOG);
2974         }
2975 }
2976
2977 # make_datestr()
2978 sub make_datestr
2979 {
2980 local @tm = localtime(time());
2981 return sprintf "%2.2d/%s/%4.4d:%2.2d:%2.2d:%2.2d %s",
2982                 $tm[3], $month[$tm[4]], $tm[5]+1900,
2983                 $tm[2], $tm[1], $tm[0], $timezone;
2984 }
2985
2986 # log_error(message)
2987 sub log_error
2988 {
2989 seek(STDERR, 0, 2);
2990 print STDERR "[",&make_datestr(),"] ",
2991         $acpthost ? ( "[",$acpthost,"] " ) : ( ),
2992         $page ? ( $page," : " ) : ( ),
2993         @_,"\n";
2994 }
2995
2996 # read_errors(handle)
2997 # Read and return all input from some filehandle
2998 sub read_errors
2999 {
3000 local($fh, $_, $rv);
3001 $fh = $_[0];
3002 while(<$fh>) { $rv .= $_; }
3003 return $rv;
3004 }
3005
3006 sub write_keep_alive
3007 {
3008 local $mode;
3009 if ($config{'nokeepalive'}) {
3010         # Keep alives have been disabled in config
3011         $mode = 0;
3012         }
3013 elsif (@childpids > $config{'maxconns'}*.8) {
3014         # Disable because nearing process limit
3015         $mode = 0;
3016         }
3017 elsif (@_) {
3018         # Keep alive specified by caller
3019         $mode = $_[0];
3020         }
3021 else {
3022         # Keep alive determined by browser
3023         $mode = $header{'connection'} =~ /keep-alive/i;
3024         }
3025 &write_data("Connection: ".($mode ? "Keep-Alive" : "close")."\r\n");
3026 return $mode;
3027 }
3028
3029 sub term_handler
3030 {
3031 kill('TERM', @childpids) if (@childpids);
3032 kill('KILL', $logclearer) if ($logclearer);
3033 kill('KILL', $extauth) if ($extauth);
3034 exit(1);
3035 }
3036
3037 sub http_date
3038 {
3039 local @tm = gmtime($_[0]);
3040 return sprintf "%s, %d %s %d %2.2d:%2.2d:%2.2d GMT",
3041                 $weekday[$tm[6]], $tm[3], $month[$tm[4]], $tm[5]+1900,
3042                 $tm[2], $tm[1], $tm[0];
3043 }
3044
3045 sub TIEHANDLE
3046 {
3047 my $i; bless \$i, shift;
3048 }
3049
3050 sub WRITE
3051 {
3052 $r = shift;
3053 my($buf,$len,$offset) = @_;
3054 &write_to_sock(substr($buf, $offset, $len));
3055 $miniserv::page_capture_out .= substr($buf, $offset, $len)
3056         if ($miniserv::page_capture);
3057 }
3058
3059 sub PRINT
3060 {
3061 $r = shift;
3062 $$r++;
3063 my $buf = join(defined($,) ? $, : "", @_);
3064 $buf .= $\ if defined($\);
3065 &write_to_sock($buf);
3066 $miniserv::page_capture_out .= $buf
3067         if ($miniserv::page_capture);
3068 }
3069
3070 sub PRINTF
3071 {
3072 shift;
3073 my $fmt = shift;
3074 my $buf = sprintf $fmt, @_;
3075 &write_to_sock($buf);
3076 $miniserv::page_capture_out .= $buf
3077         if ($miniserv::page_capture);
3078 }
3079
3080 # Send back already read data while we have it, then read from SOCK
3081 sub READ
3082 {
3083 my $r = shift;
3084 my $bufref = \$_[0];
3085 my $len = $_[1];
3086 my $offset = $_[2];
3087 if ($postpos < length($postinput)) {
3088         # Reading from already fetched array
3089         my $left = length($postinput) - $postpos;
3090         my $canread = $len > $left ? $left : $len;
3091         substr($$bufref, $offset, $canread) =
3092                 substr($postinput, $postpos, $canread);
3093         $postpos += $canread;
3094         return $canread;
3095         }
3096 else {
3097         # Read from network socket
3098         local $data = &read_data($len);
3099         if ($data eq '' && $len) {
3100                 # End of socket
3101                 print STDERR "finished reading - shutting down socket\n";
3102                 shutdown(SOCK, 0);
3103                 }
3104         substr($$bufref, $offset, length($data)) = $data;
3105         return length($data);
3106         }
3107 }
3108
3109 sub OPEN
3110 {
3111 #print STDERR "open() called - should never happen!\n";
3112 }
3113
3114 # Read a line of input
3115 sub READLINE
3116 {
3117 my $r = shift;
3118 if ($postpos < length($postinput) &&
3119     ($idx = index($postinput, "\n", $postpos)) >= 0) {
3120         # A line exists in the memory buffer .. use it
3121         my $line = substr($postinput, $postpos, $idx-$postpos+1);
3122         $postpos = $idx+1;
3123         return $line;
3124         }
3125 else {
3126         # Need to read from the socket
3127         my $line;
3128         if ($postpos < length($postinput)) {
3129                 # Start with in-memory data
3130                 $line = substr($postinput, $postpos);
3131                 $postpos = length($postinput);
3132                 }
3133         my $nl = &read_line(0, 1);
3134         if ($nl eq '') {
3135                 # End of socket
3136                 print STDERR "finished reading - shutting down socket\n";
3137                 shutdown(SOCK, 0);
3138                 }
3139         $line .= $nl if (defined($nl));
3140         return $line;
3141         }
3142 }
3143
3144 # Read one character of input
3145 sub GETC
3146 {
3147 my $r = shift;
3148 my $buf;
3149 my $got = READ($r, \$buf, 1, 0);
3150 return $got > 0 ? $buf : undef;
3151 }
3152
3153 sub FILENO
3154 {
3155 return fileno(SOCK);
3156 }
3157
3158 sub CLOSE { }
3159
3160 sub DESTROY { }
3161
3162 # write_to_sock(data, ...)
3163 sub write_to_sock
3164 {
3165 local $d;
3166 foreach $d (@_) {
3167         if ($doneheaders || $miniserv::nph_script) {
3168                 &write_data($d);
3169                 }
3170         else {
3171                 $headers .= $d;
3172                 while(!$doneheaders && $headers =~ s/^([^\r\n]*)(\r)?\n//) {
3173                         if ($1 =~ /^(\S+):\s+(.*)$/) {
3174                                 $cgiheader{lc($1)} = $2;
3175                                 push(@cgiheader, [ $1, $2 ]);
3176                                 }
3177                         elsif ($1 !~ /\S/) {
3178                                 $doneheaders++;
3179                                 }
3180                         else {
3181                                 &http_error(500, "Bad Header");
3182                                 }
3183                         }
3184                 if ($doneheaders) {
3185                         if ($cgiheader{"location"}) {
3186                                 &write_data(
3187                                         "HTTP/1.0 302 Moved Temporarily\r\n");
3188                                 &write_data("Date: $datestr\r\n");
3189                                 &write_data("Server: $config{server}\r\n");
3190                                 &write_keep_alive(0);
3191                                 }
3192                         elsif ($cgiheader{"content-type"} eq "") {
3193                                 &http_error(500, "Missing Content-Type Header");
3194                                 }
3195                         else {
3196                                 &write_data("HTTP/1.0 $ok_code $ok_message\r\n");
3197                                 &write_data("Date: $datestr\r\n");
3198                                 &write_data("Server: $config{server}\r\n");
3199                                 &write_keep_alive(0);
3200                                 }
3201                         foreach $h (@cgiheader) {
3202                                 &write_data("$h->[0]: $h->[1]\r\n");
3203                                 }
3204                         &write_data("\r\n");
3205                         &reset_byte_count();
3206                         &write_data($headers);
3207                         }
3208                 }
3209         }
3210 }
3211
3212 sub verify_client
3213 {
3214 local $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($_[1]);
3215 if ($cert) {
3216         local $errnum = Net::SSLeay::X509_STORE_CTX_get_error($_[1]);
3217         $verified_client = 1 if (!$errnum);
3218         }
3219 return 1;
3220 }
3221
3222 sub END
3223 {
3224 if ($doing_cgi_eval && $$ == $main_process_id) {
3225         # A CGI program called exit! This is a horrible hack to
3226         # finish up before really exiting
3227         shutdown(SOCK, 1);
3228         close(SOCK);
3229         close($PASSINw); close($PASSOUTw);
3230         &log_request($acpthost, $authuser, $reqline,
3231                      $cgiheader{"location"} ? "302" : $ok_code, &byte_count());
3232         }
3233 }
3234
3235 # urlize
3236 # Convert a string to a form ok for putting in a URL
3237 sub urlize {
3238   local($tmp, $tmp2, $c);
3239   $tmp = $_[0];
3240   $tmp2 = "";
3241   while(($c = chop($tmp)) ne "") {
3242         if ($c !~ /[A-z0-9]/) {
3243                 $c = sprintf("%%%2.2X", ord($c));
3244                 }
3245         $tmp2 = $c . $tmp2;
3246         }
3247   return $tmp2;
3248 }
3249
3250 # validate_user(username, password, host, remote-ip, webmin-port)
3251 # Checks if some username and password are valid. Returns the modified username,
3252 # the expired / temp pass flag, and the non-existence flag
3253 sub validate_user
3254 {
3255 local ($user, $pass, $host, $actpip, $port) = @_;
3256 return ( ) if (!$user);
3257 print DEBUG "validate_user: user=$user pass=$pass host=$host\n";
3258 local ($canuser, $canmode, $notexist, $webminuser, $sudo) =
3259         &can_user_login($user, undef, $host);
3260 print DEBUG "validate_user: canuser=$canuser canmode=$canmode notexist=$notexist webminuser=$webminuser sudo=$sudo\n";
3261 if ($notexist) {
3262         # User doesn't even exist, so go no further
3263         return ( undef, 0, 1 );
3264         }
3265 elsif ($canmode == 0) {
3266         # User does exist but cannot login
3267         return ( $canuser, 0, 0 );
3268         }
3269 elsif ($canmode == 1) {
3270         # Attempt Webmin authentication
3271         my $uinfo = &get_user_details($webminuser);
3272         if ($uinfo &&
3273             &password_crypt($pass, $uinfo->{'pass'}) eq $uinfo->{'pass'}) {
3274                 # Password is valid .. but check for expiry
3275                 local $lc = $uinfo->{'lastchanges'};
3276                 print DEBUG "validate_user: Password is valid lc=$lc pass_maxdays=$config{'pass_maxdays'}\n";
3277                 if ($config{'pass_maxdays'} && $lc && !$uinfo->{'nochange'}) {
3278                         local $daysold = (time() - $lc)/(24*60*60);
3279                         print DEBUG "maxdays=$config{'pass_maxdays'} daysold=$daysold temppass=$uinfo->{'temppass'}\n";
3280                         if ($config{'pass_lockdays'} &&
3281                             $daysold > $config{'pass_lockdays'}) {
3282                                 # So old that the account is locked
3283                                 return ( undef, 0, 0 );
3284                                 }
3285                         elsif ($daysold > $config{'pass_maxdays'}) {
3286                                 # Password has expired
3287                                 return ( $user, 1, 0 );
3288                                 }
3289                         }
3290                 if ($uinfo->{'temppass'}) {
3291                         # Temporary password - force change now
3292                         return ( $user, 2, 0 );
3293                         }
3294                 return ( $user, 0, 0 );
3295                 }
3296         elsif (!$uinfo) {
3297                 print DEBUG "validate_user: User $webminuser not found\n";
3298                 return ( undef, 0, 0 );
3299                 }
3300         else {
3301                 print DEBUG "validate_user: User $webminuser password mismatch $pass != $uinfo->{'pass'}\n";
3302                 return ( undef, 0, 0 );
3303                 }
3304         }
3305 elsif ($canmode == 2 || $canmode == 3) {
3306         # Attempt PAM or passwd file authentication
3307         local $val = &validate_unix_user($canuser, $pass, $acptip, $port);
3308         print DEBUG "validate_user: unix val=$val\n";
3309         if ($val && $sudo) {
3310                 # Need to check if this Unix user can sudo
3311                 if (!&check_sudo_permissions($canuser, $pass)) {
3312                         print DEBUG "validate_user: sudo failed\n";
3313                         $val = 0;
3314                         }
3315                 else {
3316                         print DEBUG "validate_user: sudo passed\n";
3317                         }
3318                 }
3319         return $val == 2 ? ( $canuser, 1, 0 ) :
3320                $val == 1 ? ( $canuser, 0, 0 ) : ( undef, 0, 0 );
3321         }
3322 elsif ($canmode == 4) {
3323         # Attempt external authentication
3324         return &validate_external_user($canuser, $pass) ?
3325                 ( $canuser, 0, 0 ) : ( undef, 0, 0 );
3326         }
3327 else {
3328         # Can't happen!
3329         return ( );
3330         }
3331 }
3332
3333 # validate_unix_user(user, password, remote-ip, local-port)
3334 # Returns 1 if a username and password are valid under unix, 0 if not,
3335 # or 2 if the account has expired.
3336 # Checks PAM if available, and falls back to reading the system password
3337 # file otherwise.
3338 sub validate_unix_user
3339 {
3340 if ($use_pam) {
3341         # Check with PAM
3342         $pam_username = $_[0];
3343         $pam_password = $_[1];
3344         eval "use Authen::PAM;";
3345         local $pamh = new Authen::PAM($config{'pam'}, $pam_username,
3346                                       \&pam_conv_func);
3347         if (ref($pamh)) {
3348                 $pamh->pam_set_item("PAM_RHOST", $_[2]) if ($_[2]);
3349                 $pamh->pam_set_item("PAM_TTY", $_[3]) if ($_[3]);
3350                 local $pam_ret = $pamh->pam_authenticate();
3351                 if ($pam_ret == PAM_SUCCESS()) {
3352                         # Logged in OK .. make sure password hasn't expired
3353                         local $acct_ret = $pamh->pam_acct_mgmt();
3354                         if ($acct_ret == PAM_SUCCESS()) {
3355                                 $pamh->pam_open_session();
3356                                 return 1;
3357                                 }
3358                         elsif ($acct_ret == PAM_NEW_AUTHTOK_REQD() ||
3359                                $acct_ret == PAM_ACCT_EXPIRED()) {
3360                                 return 2;
3361                                 }
3362                         else {
3363                                 print STDERR "Unknown pam_acct_mgmt return value : $acct_ret\n";
3364                                 return 0;
3365                                 }
3366                         }
3367                 return 0;
3368                 }
3369         }
3370 elsif ($config{'pam_only'}) {
3371         # Pam is not available, but configuration forces it's use!
3372         return 0;
3373         }
3374 elsif ($config{'passwd_file'}) {
3375         # Check in a password file
3376         local $rv = 0;
3377         open(FILE, $config{'passwd_file'});
3378         if ($config{'passwd_file'} eq '/etc/security/passwd') {
3379                 # Assume in AIX format
3380                 while(<FILE>) {
3381                         s/\s*$//;
3382                         if (/^\s*(\S+):/ && $1 eq $_[0]) {
3383                                 $_ = <FILE>;
3384                                 if (/^\s*password\s*=\s*(\S+)\s*$/) {
3385                                         $rv = $1 eq &password_crypt($_[1], $1) ?
3386                                                 1 : 0;
3387                                         }
3388                                 last;
3389                                 }
3390                         }
3391                 }
3392         else {
3393                 # Read the system password or shadow file
3394                 while(<FILE>) {
3395                         local @l = split(/:/, $_, -1);
3396                         local $u = $l[$config{'passwd_uindex'}];
3397                         local $p = $l[$config{'passwd_pindex'}];
3398                         if ($u eq $_[0]) {
3399                                 $rv = $p eq &password_crypt($_[1], $p) ? 1 : 0;
3400                                 if ($config{'passwd_cindex'} ne '' && $rv) {
3401                                         # Password may have expired!
3402                                         local $c = $l[$config{'passwd_cindex'}];
3403                                         local $m = $l[$config{'passwd_mindex'}];
3404                                         local $day = time()/(24*60*60);
3405                                         if ($c =~ /^\d+/ && $m =~ /^\d+/ &&
3406                                             $day - $c > $m) {
3407                                                 # Yep, it has ..
3408                                                 $rv = 2;
3409                                                 }
3410                                         }
3411                                 if ($p eq "" && $config{'passwd_blank'}) {
3412                                         # Force password change
3413                                         $rv = 2;
3414                                         }
3415                                 last;
3416                                 }
3417                         }
3418                 }
3419         close(FILE);
3420         return $rv if ($rv);
3421         }
3422
3423 # Fallback option - check password returned by getpw*
3424 local @uinfo = getpwnam($_[0]);
3425 if ($uinfo[1] ne '' && &password_crypt($_[1], $uinfo[1]) eq $uinfo[1]) {
3426         return 1;
3427         }
3428
3429 return 0;       # Totally failed
3430 }
3431
3432 # validate_external_user(user, pass)
3433 # Validate a user by passing the username and password to an external
3434 # squid-style authentication program
3435 sub validate_external_user
3436 {
3437 return 0 if (!$config{'extauth'});
3438 flock(EXTAUTH, 2);
3439 local $str = "$_[0] $_[1]\n";
3440 syswrite(EXTAUTH, $str, length($str));
3441 local $resp = <EXTAUTH>;
3442 flock(EXTAUTH, 8);
3443 return $resp =~ /^OK/i ? 1 : 0;
3444 }
3445
3446 # can_user_login(username, no-append, host)
3447 # Checks if a user can login or not.
3448 # First return value is the username.
3449 # Second is 0 if cannot login, 1 if using Webmin pass, 2 if PAM, 3 if password
3450 # file, 4 if external.
3451 # Third is 1 if the user does not exist at all, 0 if he does.
3452 # Fourth is the Webmin username whose permissions apply, based on unixauth.
3453 # Fifth is a flag indicating if a sudo check is needed.
3454 sub can_user_login
3455 {
3456 local $uinfo = &get_user_details($_[0]);
3457 if (!$uinfo) {
3458         # See if this user exists in Unix and can be validated by the same
3459         # method as the unixauth webmin user
3460         local $realuser = $unixauth{$_[0]};
3461         local @uinfo;
3462         local $sudo = 0;
3463         local $pamany = 0;
3464         eval { @uinfo = getpwnam($_[0]); };     # may fail on windows
3465         if (!$realuser && @uinfo) {
3466                 # No unixauth entry for the username .. try his groups
3467                 foreach my $ua (keys %unixauth) {
3468                         if ($ua =~ /^\@(.*)$/) {
3469                                 if (&is_group_member(\@uinfo, $1)) {
3470                                         $realuser = $unixauth{$ua};
3471                                         last;
3472                                         }
3473                                 }
3474                         }
3475                 }
3476         if (!$realuser && @uinfo) {
3477                 # Fall back to unix auth for all Unix users
3478                 $realuser = $unixauth{"*"};
3479                 }
3480         if (!$realuser && $use_sudo && @uinfo) {
3481                 # Allow login effectively as root, if sudo permits it
3482                 $sudo = 1;
3483                 $realuser = "root";
3484                 }
3485         if (!$realuser && !@uinfo && $config{'pamany'}) {
3486                 # If the user completely doesn't exist, we can still allow
3487                 # him to authenticate via PAM
3488                 $realuser = $config{'pamany'};
3489                 $pamany = 1;
3490                 }
3491         if (!$realuser) {
3492                 # For Usermin, always fall back to unix auth for any user,
3493                 # so that later checks with domain added / removed are done.
3494                 $realuser = $unixauth{"*"};
3495                 }
3496         return (undef, 0, 1, undef) if (!$realuser);
3497         local $uinfo = &get_user_details($realuser);
3498         return (undef, 0, 1, undef) if (!$uinfo);
3499         local $up = $uinfo->{'pass'};
3500
3501         # Work out possible domain names from the hostname
3502         local @doms = ( $_[2] );
3503         if ($_[2] =~ /^([^\.]+)\.(\S+)$/) {
3504                 push(@doms, $2);
3505                 }
3506
3507         if ($config{'user_mapping'} && !%user_mapping) {
3508                 # Read the user mapping file
3509                 %user_mapping = ();
3510                 open(MAPPING, $config{'user_mapping'});
3511                 while(<MAPPING>) {
3512                         s/\r|\n//g;
3513                         s/#.*$//;
3514                         if (/^(\S+)\s+(\S+)/) {
3515                                 if ($config{'user_mapping_reverse'}) {
3516                                         $user_mapping{$1} = $2;
3517                                         }
3518                                 else {
3519                                         $user_mapping{$2} = $1;
3520                                         }
3521                                 }
3522                         }
3523                 close(MAPPING);
3524                 }
3525
3526         # Check the user mapping file to see if there is an entry for the
3527         # user login in which specifies a new effective user
3528         local $um;
3529         foreach my $d (@doms) {
3530                 $um ||= $user_mapping{"$_[0]\@$d"};
3531                 }
3532         $um ||= $user_mapping{$_[0]};
3533         if (defined($um) && ($_[1]&4) == 0) {
3534                 # A mapping exists - use it!
3535                 return &can_user_login($um, $_[1]+4, $_[2]);
3536                 }
3537
3538         # Check if a user with the entered login and the domains appended
3539         # or prepended exists, and if so take it to be the effective user
3540         if (!@uinfo && $config{'domainuser'}) {
3541                 # Try again with name.domain and name.firstpart
3542                 local @firsts = map { /^([^\.]+)/; $1 } @doms;
3543                 if (($_[1]&1) == 0) {
3544                         local ($a, $p);
3545                         foreach $a (@firsts, @doms) {
3546                                 foreach $p ("$_[0].${a}", "$_[0]-${a}",
3547                                             "${a}.$_[0]", "${a}-$_[0]",
3548                                             "$_[0]_${a}", "${a}_$_[0]") {
3549                                         local @vu = &can_user_login(
3550                                                         $p, $_[1]+1, $_[2]);
3551                                         return @vu if ($vu[1]);
3552                                         }
3553                                 }
3554                         }
3555                 }
3556
3557         # Check if the user entered a domain at the end of his username when
3558         # he really shouldn't have, and if so try without it
3559         if (!@uinfo && $config{'domainstrip'} &&
3560             $_[0] =~ /^(\S+)\@(\S+)$/ && ($_[1]&2) == 0) {
3561                 local ($stripped, $dom) = ($1, $2);
3562                 local @vu = &can_user_login($stripped, $_[1] + 2, $_[2]);
3563                 return @vu if ($vu[1]);
3564                 local @vu = &can_user_login($stripped, $_[1] + 2, $dom);
3565                 return @vu if ($vu[1]);
3566                 }
3567
3568         return ( undef, 0, 1, undef ) if (!@uinfo && !$pamany);
3569
3570         if (@uinfo) {
3571                 if (scalar(@allowusers)) {
3572                         # Only allow people on the allow list
3573                         return ( undef, 0, 0, undef )
3574                                 if (!&users_match(\@uinfo, @allowusers));
3575                         }
3576                 elsif (scalar(@denyusers)) {
3577                         # Disallow people on the deny list
3578                         return ( undef, 0, 0, undef )
3579                                 if (&users_match(\@uinfo, @denyusers));
3580                         }
3581                 if ($config{'shells_deny'}) {
3582                         local $found = 0;
3583                         open(SHELLS, $config{'shells_deny'});
3584                         while(<SHELLS>) {
3585                                 s/\r|\n//g;
3586                                 s/#.*$//;
3587                                 $found++ if ($_ eq $uinfo[8]);
3588                                 }
3589                         close(SHELLS);
3590                         return ( undef, 0, 0, undef ) if (!$found);
3591                         }
3592                 }
3593
3594         if ($up eq 'x') {
3595                 # PAM or passwd file authentication
3596                 print DEBUG "can_user_login: Validate with PAM\n";
3597                 return ( $_[0], $use_pam ? 2 : 3, 0, $realuser, $sudo );
3598                 }
3599         elsif ($up eq 'e') {
3600                 # External authentication
3601                 print DEBUG "can_user_login: Validate externally\n";
3602                 return ( $_[0], 4, 0, $realuser, $sudo );
3603                 }
3604         else {
3605                 # Fixed Webmin password
3606                 print DEBUG "can_user_login: Validate by Webmin\n";
3607                 return ( $_[0], 1, 0, $realuser, $sudo );
3608                 }
3609         }
3610 elsif ($uinfo->{'pass'} eq 'x') {
3611         # Webmin user authenticated via PAM or password file
3612         return ( $_[0], $use_pam ? 2 : 3, 0, $_[0] );
3613         }
3614 elsif ($uinfo->{'pass'} eq 'e') {
3615         # Webmin user authenticated externally
3616         return ( $_[0], 4, 0, $_[0] );
3617         }
3618 else {
3619         # Normal Webmin user
3620         return ( $_[0], 1, 0, $_[0] );
3621         }
3622 }
3623
3624 # the PAM conversation function for interactive logins
3625 sub pam_conv_func
3626 {
3627 $pam_conv_func_called++;
3628 my @res;
3629 while ( @_ ) {
3630         my $code = shift;
3631         my $msg = shift;
3632         my $ans = "";
3633
3634         $ans = $pam_username if ($code == PAM_PROMPT_ECHO_ON() );
3635         $ans = $pam_password if ($code == PAM_PROMPT_ECHO_OFF() );
3636
3637         push @res, PAM_SUCCESS();
3638         push @res, $ans;
3639         }
3640 push @res, PAM_SUCCESS();
3641 return @res;
3642 }
3643
3644 sub urandom_timeout
3645 {
3646 close(RANDOM);
3647 }
3648
3649 # get_socket_ip(handle, ipv6-flag)
3650 # Returns the local IP address of some connection, as both a string and in
3651 # binary format
3652 sub get_socket_ip
3653 {
3654 local ($fh, $ipv6) = @_;
3655 local $sn = getsockname($fh);
3656 return undef if (!$sn);
3657 return &get_address_ip($sn, $ipv6);
3658 }
3659
3660 # get_address_ip(address, ipv6-flag)
3661 # Given a sockaddr object in binary format, return the binary address, text
3662 # address and port number
3663 sub get_address_ip
3664 {
3665 local ($sn, $ipv6) = @_;
3666 if ($ipv6) {
3667         local ($p, $b) = unpack_sockaddr_in6($sn);
3668         return ($b, inet_ntop(Socket6::AF_INET6(), $b), $p);
3669         }
3670 else {
3671         local ($p, $b) = unpack_sockaddr_in($sn);
3672         return ($b, inet_ntoa($b), $p);
3673         }
3674 }
3675
3676 # get_socket_name(handle, ipv6-flag)
3677 # Returns the local hostname or IP address of some connection
3678 sub get_socket_name
3679 {
3680 local ($fh, $ipv6) = @_;
3681 return $config{'host'} if ($config{'host'});
3682 local ($mybin, $myaddr) = &get_socket_ip($fh, $ipv6);
3683 if (!$get_socket_name_cache{$myaddr}) {
3684         local $myname;
3685         if (!$config{'no_resolv_myname'}) {
3686                 $myname = gethostbyaddr($mybin,
3687                                         $ipv6 ? Socket6::AF_INET6() : AF_INET);
3688                 }
3689         $myname ||= $myaddr;
3690         $get_socket_name_cache{$myaddr} = $myname;
3691         }
3692 return $get_socket_name_cache{$myaddr};
3693 }
3694
3695 # run_login_script(username, sid, remoteip, localip)
3696 sub run_login_script
3697 {
3698 if ($config{'login_script'}) {
3699         system($config{'login_script'}.
3700                " ".join(" ", map { quotemeta($_) || '""' } @_).
3701                " >/dev/null 2>&1 </dev/null");
3702         }
3703 }
3704
3705 # run_logout_script(username, sid, remoteip, localip)
3706 sub run_logout_script
3707 {
3708 if ($config{'logout_script'}) {
3709         system($config{'logout_script'}.
3710                " ".join(" ", map { quotemeta($_) || '""' } @_).
3711                " >/dev/null 2>&1 </dev/null");
3712         }
3713 }
3714
3715 # close_all_sockets()
3716 # Closes all the main listening sockets
3717 sub close_all_sockets
3718 {
3719 local $s;
3720 foreach $s (@socketfhs) {
3721         close($s);
3722         }
3723 }
3724
3725 # close_all_pipes()
3726 # Close all pipes for talking to sub-processes
3727 sub close_all_pipes
3728 {
3729 local $p;
3730 foreach $p (@passin) { close($p); }
3731 foreach $p (@passout) { close($p); }
3732 foreach $p (values %conversations) {
3733         if ($p->{'PAMOUTr'}) {
3734                 close($p->{'PAMOUTr'});
3735                 close($p->{'PAMINw'});
3736                 }
3737         }
3738 }
3739
3740 # check_user_ip(user)
3741 # Returns 1 if some user is allowed to login from the accepting IP, 0 if not
3742 sub check_user_ip
3743 {
3744 local ($username) = @_;
3745 local $uinfo = &get_user_details($username);
3746 return 1 if (!$uinfo);
3747 if ($uinfo->{'deny'} &&
3748     &ip_match($acptip, $localip, @{$uinfo->{'deny'}}) ||
3749     $uinfo->{'allow'} &&
3750     !&ip_match($acptip, $localip, @{$uinfo->{'allow'}})) {
3751         return 0;
3752         }
3753 return 1;
3754 }
3755
3756 # check_user_time(user)
3757 # Returns 1 if some user is allowed to login at the current date and time
3758 sub check_user_time
3759 {
3760 local ($username) = @_;
3761 local $uinfo = &get_user_details($username);
3762 return 1 if (!$uinfo || !$uinfo->{'allowdays'} && !$uinfo->{'allowhours'});
3763 local @tm = localtime(time());
3764 if ($uinfo->{'allowdays'}) {
3765         # Make sure day is allowed
3766         return 0 if (&indexof($tm[6], @{$uinfo->{'allowdays'}}) < 0);
3767         }
3768 if ($uinfo->{'allowhours'}) {
3769         # Make sure time is allowed
3770         local $m = $tm[2]*60+$tm[1];
3771         return 0 if ($m < $uinfo->{'allowhours'}->[0] ||
3772                      $m > $uinfo->{'allowhours'}->[1]);
3773         }
3774 return 1;
3775 }
3776
3777 # generate_random_id(password, [force-urandom])
3778 # Returns a random session ID number
3779 sub generate_random_id
3780 {
3781 local ($pass, $force_urandom) = @_;
3782 local $sid;
3783 if (!$bad_urandom) {
3784         # First try /dev/urandom, unless we have marked it as bad
3785         $SIG{ALRM} = "miniserv::urandom_timeout";
3786         alarm(5);
3787         if (open(RANDOM, "/dev/urandom")) {
3788                 my $tmpsid;
3789                 if (read(RANDOM, $tmpsid, 16) == 16) {
3790                         $sid = lc(unpack('h*',$tmpsid));
3791                         }
3792                 close(RANDOM);
3793                 }
3794         alarm(0);
3795         }
3796 if (!$sid && !$force_urandom) {
3797         $sid = time();
3798         local $mul = 1;
3799         foreach $c (split(//, &unix_crypt($pass, substr($$, -2)))) {
3800                 $sid += ord($c) * $mul;
3801                 $mul *= 3;
3802                 }
3803         }
3804 return $sid;
3805 }
3806
3807 # handle_login(username, ok, expired, not-exists, password, [no-test-cookie])
3808 # Called from handle_session to either mark a user as logged in, or not
3809 sub handle_login
3810 {
3811 local ($vu, $ok, $expired, $nonexist, $pass, $notest) = @_;
3812 $authuser = $vu if ($ok);
3813
3814 # check if the test cookie is set
3815 if ($header{'cookie'} !~ /testing=1/ && $vu &&
3816     !$config{'no_testing_cookie'} && !$notest) {
3817         &http_error(500, "No cookies",
3818            "Your browser does not support cookies, ".
3819            "which are required for this web server to ".
3820            "work in session authentication mode");
3821         }
3822
3823 # check with main process for delay
3824 if ($config{'passdelay'} && $vu) {
3825         print DEBUG "handle_login: requesting delay vu=$vu acptip=$acptip ok=$ok\n";
3826         print $PASSINw "delay $vu $acptip $ok\n";
3827         <$PASSOUTr> =~ /(\d+) (\d+)/;
3828         $blocked = $2;
3829         sleep($1);
3830         print DEBUG "handle_login: delay=$1 blocked=$2\n";
3831         }
3832
3833 if ($ok && (!$expired ||
3834             $config{'passwd_mode'} == 1)) {
3835         # Logged in OK! Tell the main process about
3836         # the new SID
3837         local $sid = &generate_random_id($pass);
3838         print DEBUG "handle_login: sid=$sid\n";
3839         print $PASSINw "new $sid $authuser $acptip\n";
3840
3841         # Run the post-login script, if any
3842         &run_login_script($authuser, $sid,
3843                           $acptip, $localip);
3844
3845         # Check for a redirect URL for the user
3846         local $rurl = &login_redirect($authuser, $pass, $host);
3847         print DEBUG "handle_login: redirect URL rurl=$rurl\n";
3848         if ($rurl) {
3849                 # Got one .. go to it
3850                 &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
3851                 &write_data("Date: $datestr\r\n");
3852                 &write_data("Server: $config{'server'}\r\n");
3853                 &write_data("Location: $rurl\r\n");
3854                 &write_keep_alive(0);
3855                 &write_data("\r\n");
3856                 &log_request($acpthost, $authuser, $reqline, 302, 0);
3857                 }
3858         else {
3859                 # Set cookie and redirect to originally requested page
3860                 &write_data("HTTP/1.0 302 Moved Temporarily\r\n");
3861                 &write_data("Date: $datestr\r\n");
3862                 &write_data("Server: $config{'server'}\r\n");
3863                 local $ssl = $use_ssl || $config{'inetd_ssl'};
3864                 $portstr = $port == 80 && !$ssl ? "" :
3865                            $port == 443 && $ssl ? "" : ":$port";
3866                 $prot = $ssl ? "https" : "http";
3867                 local $sec = $ssl ? "; secure" : "";
3868                 #$sec .= "; httpOnly";
3869                 if ($in{'page'} !~ /^\/[A-Za-z0-9\/\.\-\_]+$/) {
3870                         # Make redirect URL safe
3871                         $in{'page'} = "/";
3872                         }
3873                 if ($in{'save'}) {
3874                         &write_data("Set-Cookie: $sidname=$sid; path=/; expires=\"Thu, 31-Dec-2037 00:00:00\"$sec\r\n");
3875                         }
3876                 else {
3877                         &write_data("Set-Cookie: $sidname=$sid; path=/$sec\r\n");
3878                         }
3879                 &write_data("Location: $prot://$host$portstr$in{'page'}\r\n");
3880                 &write_keep_alive(0);
3881                 &write_data("\r\n");
3882                 &log_request($acpthost, $authuser, $reqline, 302, 0);
3883                 syslog("info", "%s", "Successful login as $authuser from $acpthost") if ($use_syslog);
3884                 &write_login_utmp($authuser, $acpthost);
3885                 }
3886         return 0;
3887         }
3888 elsif ($ok && $expired &&
3889        ($config{'passwd_mode'} == 2 || $expired == 2)) {
3890         # Login was ok, but password has expired or was temporary. Need
3891         # to force display of password change form.
3892         $validated = 1;
3893         $authuser = undef;
3894         $querystring = "&user=".&urlize($vu).
3895                        "&pam=".$use_pam.
3896                        "&expired=".$expired;
3897         $method = "GET";
3898         $queryargs = "";
3899         $page = $config{'password_form'};
3900         $logged_code = 401;
3901         $miniserv_internal = 2;
3902         syslog("crit", "%s",
3903                 "Expired login as $vu ".
3904                 "from $acpthost") if ($use_syslog);
3905         }
3906 else {
3907         # Login failed, or password has expired. The login form will be
3908         # displayed again by later code
3909         $failed_user = $vu;
3910         $request_uri = $in{'page'};
3911         $already_session_id = undef;
3912         $method = "GET";
3913         $authuser = $baseauthuser = undef;
3914         syslog("crit", "%s",
3915                 ($nonexist ? "Non-existent" :
3916                  $expired ? "Expired" : "Invalid").
3917                 " login as $vu from $acpthost")
3918                 if ($use_syslog);
3919         }
3920 return undef;
3921 }
3922
3923 # write_login_utmp(user, host)
3924 # Record the login by some user in utmp
3925 sub write_login_utmp
3926 {
3927 if ($write_utmp) {
3928         # Write utmp record for login
3929         %utmp = ( 'ut_host' => $_[1],
3930                   'ut_time' => time(),
3931                   'ut_user' => $_[0],
3932                   'ut_type' => 7,       # user process
3933                   'ut_pid' => $main_process_id,
3934                   'ut_line' => $config{'pam'},
3935                   'ut_id' => '' );
3936         if (defined(&User::Utmp::putut)) {
3937                 User::Utmp::putut(\%utmp);
3938                 }
3939         else {
3940                 User::Utmp::pututline(\%utmp);
3941                 }
3942         }
3943 }
3944
3945 # write_logout_utmp(user, host)
3946 # Record the logout by some user in utmp
3947 sub write_logout_utmp
3948 {
3949 if ($write_utmp) {
3950         # Write utmp record for logout
3951         %utmp = ( 'ut_host' => $_[1],
3952                   'ut_time' => time(),
3953                   'ut_user' => $_[0],
3954                   'ut_type' => 8,       # dead process
3955                   'ut_pid' => $main_process_id,
3956                   'ut_line' => $config{'pam'},
3957                   'ut_id' => '' );
3958         if (defined(&User::Utmp::putut)) {
3959                 User::Utmp::putut(\%utmp);
3960                 }
3961         else {
3962                 User::Utmp::pututline(\%utmp);
3963                 }
3964         }
3965 }
3966
3967 # pam_conversation_process(username, write-pipe, read-pipe)
3968 # This function is called inside a sub-process to communicate with PAM. It sends
3969 # questions down one pipe, and reads responses from another
3970 sub pam_conversation_process
3971 {
3972 local ($user, $writer, $reader) = @_;
3973 $miniserv::pam_conversation_process_writer = $writer;
3974 $miniserv::pam_conversation_process_reader = $reader;
3975 eval "use Authen::PAM;";
3976 local $convh = new Authen::PAM(
3977         $config{'pam'}, $user, \&miniserv::pam_conversation_process_func);
3978 local $pam_ret = $convh->pam_authenticate();
3979 if ($pam_ret == PAM_SUCCESS()) {
3980         local $acct_ret = $convh->pam_acct_mgmt();
3981         if ($acct_ret == PAM_SUCCESS()) {
3982                 $convh->pam_open_session();
3983                 print $writer "x2 $user 1 0 0\n";
3984                 }
3985         elsif ($acct_ret == PAM_NEW_AUTHTOK_REQD() ||
3986                $acct_ret == PAM_ACCT_EXPIRED()) {
3987                 print $writer "x2 $user 1 1 0\n";
3988                 }
3989         else {
3990                 print $writer "x0 Unknown PAM account status $acct_ret\n";
3991                 }
3992         }
3993 else {
3994         print $writer "x2 $user 0 0 0\n";
3995         }
3996 exit(0);
3997 }
3998
3999 # pam_conversation_process_func(type, message, [type, message, ...])
4000 # A pipe that talks to both PAM and the master process
4001 sub pam_conversation_process_func
4002 {
4003 local @rv;
4004 select($miniserv::pam_conversation_process_writer); $| = 1; select(STDOUT);
4005 while(@_) {
4006         local ($type, $msg) = (shift, shift);
4007         $msg =~ s/\r|\n//g;
4008         local $ok = (print $miniserv::pam_conversation_process_writer "$type $msg\n");
4009         print $miniserv::pam_conversation_process_writer "\n";
4010         local $answer = <$miniserv::pam_conversation_process_reader>;
4011         $answer =~ s/\r|\n//g;
4012         push(@rv, PAM_SUCCESS(), $answer);
4013         }
4014 push(@rv, PAM_SUCCESS());
4015 return @rv;
4016 }
4017
4018 # allocate_pipes()
4019 # Returns 4 new pipe file handles
4020 sub allocate_pipes
4021 {
4022 local ($PASSINr, $PASSINw, $PASSOUTr, $PASSOUTw);
4023 local $p;
4024 local %taken = ( (map { $_, 1 } @passin),
4025                  (map { $_->{'PASSINr'} } values %conversations) );
4026 for($p=0; $taken{"PASSINr$p"}; $p++) { }
4027 $PASSINr = "PASSINr$p";
4028 $PASSINw = "PASSINw$p";
4029 $PASSOUTr = "PASSOUTr$p";
4030 $PASSOUTw = "PASSOUTw$p";
4031 pipe($PASSINr, $PASSINw);
4032 pipe($PASSOUTr, $PASSOUTw);
4033 select($PASSINw); $| = 1;
4034 select($PASSINr); $| = 1;
4035 select($PASSOUTw); $| = 1;
4036 select($PASSOUTw); $| = 1;
4037 select(STDOUT);
4038 return ($PASSINr, $PASSINw, $PASSOUTr, $PASSOUTw);
4039 }
4040
4041 # recv_pam_question(&conv, fd)
4042 # Reads one PAM question from the sub-process, and sends it to the HTTP handler.
4043 # Returns 0 if the conversation is over, 1 if not.
4044 sub recv_pam_question
4045 {
4046 local ($conf, $fh) = @_;
4047 local $pr = $conf->{'PAMOUTr'};
4048 select($pr); $| = 1; select(STDOUT);
4049 local $line = <$pr>;
4050 $line =~ s/\r|\n//g;
4051 if (!$line) {
4052         $line = <$pr>;
4053         $line =~ s/\r|\n//g;
4054         }
4055 $conf->{'last'} = time();
4056 if (!$line) {
4057         # Failed!
4058         print $fh "0 PAM conversation error\n";
4059         return 0;
4060         }
4061 else {
4062         local ($type, $msg) = split(/\s+/, $line, 2);
4063         if ($type =~ /^x(\d+)/) {
4064                 # Pass this status code through
4065                 print $fh "$1 $msg\n";
4066                 return $1 == 2 || $1 == 0 ? 0 : 1;
4067                 }
4068         elsif ($type == PAM_PROMPT_ECHO_ON()) {
4069                 # A normal question
4070                 print $fh "1 $msg\n";
4071                 return 1;
4072                 }
4073         elsif ($type == PAM_PROMPT_ECHO_OFF()) {
4074                 # A password
4075                 print $fh "3 $msg\n";
4076                 return 1;
4077                 }
4078         elsif ($type == PAM_ERROR_MSG() || $type == PAM_TEXT_INFO()) {
4079                 # A message that does not require a response
4080                 print $fh "4 $msg\n";
4081                 return 1;
4082                 }
4083         else {
4084                 # Unknown type!
4085                 print $fh "0 Unknown PAM message type $type\n";
4086                 return 0;
4087                 }
4088         }
4089 }
4090
4091 # send_pam_answer(&conv, answer)
4092 # Sends a response from the user to the PAM sub-process
4093 sub send_pam_answer
4094 {
4095 local ($conf, $answer) = @_;
4096 local $pw = $conf->{'PAMINw'};
4097 $conf->{'last'} = time();
4098 print $pw "$answer\n";
4099 }
4100
4101 # end_pam_conversation(&conv)
4102 # Clean up PAM conversation pipes and processes
4103 sub end_pam_conversation
4104 {
4105 local ($conv) = @_;
4106 kill('KILL', $conv->{'pid'}) if ($conv->{'pid'});
4107 if ($conv->{'PAMINr'}) {
4108         close($conv->{'PAMINr'});
4109         close($conv->{'PAMOUTr'});
4110         close($conv->{'PAMINw'});
4111         close($conv->{'PAMOUTw'});
4112         }
4113 delete($conversations{$conv->{'cid'}});
4114 }
4115
4116 # get_ipkeys(&miniserv)
4117 # Returns a list of IP address to key file mappings from a miniserv.conf entry
4118 sub get_ipkeys
4119 {
4120 local (@rv, $k);
4121 foreach $k (keys %{$_[0]}) {
4122         if ($k =~ /^ipkey_(\S+)/) {
4123                 local $ipkey = { 'ips' => [ split(/,/, $1) ],
4124                                  'key' => $_[0]->{$k},
4125                                  'index' => scalar(@rv) };
4126                 $ipkey->{'cert'} = $_[0]->{'ipcert_'.$1};
4127                 push(@rv, $ipkey);
4128                 }
4129         }
4130 return @rv;
4131 }
4132
4133 # create_ssl_context(keyfile, [certfile])
4134 sub create_ssl_context
4135 {
4136 local ($keyfile, $certfile) = @_;
4137 local $ssl_ctx;
4138 eval { $ssl_ctx = Net::SSLeay::new_x_ctx() };
4139 $ssl_ctx ||= Net::SSLeay::CTX_new();
4140 $ssl_ctx || die "Failed to create SSL context : $!";
4141 if ($client_certs) {
4142         Net::SSLeay::CTX_load_verify_locations(
4143                 $ssl_ctx, $config{'ca'}, "");
4144         Net::SSLeay::CTX_set_verify(
4145                 $ssl_ctx, &Net::SSLeay::VERIFY_PEER, \&verify_client);
4146         }
4147 if ($config{'extracas'}) {
4148         local $p;
4149         foreach $p (split(/\s+/, $config{'extracas'})) {
4150                 Net::SSLeay::CTX_load_verify_locations(
4151                         $ssl_ctx, $p, "");
4152                 }
4153         }
4154
4155 Net::SSLeay::CTX_use_RSAPrivateKey_file(
4156         $ssl_ctx, $keyfile,
4157         &Net::SSLeay::FILETYPE_PEM) || die "Failed to open SSL key $keyfile";
4158 Net::SSLeay::CTX_use_certificate_file(
4159         $ssl_ctx, $certfile || $keyfile,
4160         &Net::SSLeay::FILETYPE_PEM) || die "Failed to open SSL cert $certfile";
4161
4162 return $ssl_ctx;
4163 }
4164
4165 # ssl_connection_for_ip(socket, ipv6-flag)
4166 # Returns a new SSL connection object for some socket, or undef if failed
4167 sub ssl_connection_for_ip
4168 {
4169 local ($sock, $ipv6) = @_;
4170 local $sn = getsockname($sock);
4171 if (!$sn) {
4172         print STDERR "Failed to get address for socket $sock\n";
4173         return undef;
4174         }
4175 local (undef, $myip, undef) = &get_address_ip($sn, $ipv6);
4176 local $ssl_ctx = $ssl_contexts{$myip} || $ssl_contexts{"*"};
4177 local $ssl_con = Net::SSLeay::new($ssl_ctx);
4178 if ($config{'ssl_cipher_list'}) {
4179         # Force use of ciphers
4180         eval "Net::SSLeay::set_cipher_list(
4181                         \$ssl_con, \$config{'ssl_cipher_list'})";
4182         if ($@) {
4183                 print STDERR "SSL cipher $config{'ssl_cipher_list'} failed : ",
4184                              "$@\n";
4185                 }
4186         else {
4187                 }
4188         }
4189 Net::SSLeay::set_fd($ssl_con, fileno($sock));
4190 if (!Net::SSLeay::accept($ssl_con)) {
4191         print STDERR "Failed to initialize SSL connection\n";
4192         return undef;
4193         }
4194 return $ssl_con;
4195 }
4196
4197 # login_redirect(username, password, host)
4198 # Calls the login redirect script (if configured), which may output a URL to
4199 # re-direct a user to after logging in.
4200 sub login_redirect
4201 {
4202 return undef if (!$config{'login_redirect'});
4203 local $quser = quotemeta($_[0]);
4204 local $qpass = quotemeta($_[1]);
4205 local $qhost = quotemeta($_[2]);
4206 local $url = `$config{'login_redirect'} $quser $qpass $qhost`;
4207 chop($url);
4208 return $url;
4209 }
4210
4211 # reload_config_file()
4212 # Re-read %config, and call post-config actions
4213 sub reload_config_file
4214 {
4215 &log_error("Reloading configuration");
4216 %config = &read_config_file($config_file);
4217 &update_vital_config();
4218 &read_users_file();
4219 &read_mime_types();
4220 &build_config_mappings();
4221 &read_webmin_crons();
4222 &precache_files();
4223 if ($config{'session'}) {
4224         dbmclose(%sessiondb);
4225         dbmopen(%sessiondb, $config{'sessiondb'}, 0700);
4226         }
4227 }
4228
4229 # read_config_file(file)
4230 # Reads the given config file, and returns a hash of values
4231 sub read_config_file
4232 {
4233 local %rv;
4234 open(CONF, $_[0]) || die "Failed to open config file $_[0] : $!";
4235 while(<CONF>) {
4236         s/\r|\n//g;
4237         if (/^#/ || !/\S/) { next; }
4238         /^([^=]+)=(.*)$/;
4239         $name = $1; $val = $2;
4240         $name =~ s/^\s+//g; $name =~ s/\s+$//g;
4241         $val =~ s/^\s+//g; $val =~ s/\s+$//g;
4242         $rv{$name} = $val;
4243         }
4244 close(CONF);
4245 return %rv;
4246 }
4247
4248 # update_vital_config()
4249 # Updates %config with defaults, and dies if something vital is missing
4250 sub update_vital_config
4251 {
4252 my %vital = ("port", 80,
4253           "root", "./",
4254           "server", "MiniServ/0.01",
4255           "index_docs", "index.html index.htm index.cgi index.php",
4256           "addtype_html", "text/html",
4257           "addtype_txt", "text/plain",
4258           "addtype_gif", "image/gif",
4259           "addtype_jpg", "image/jpeg",
4260           "addtype_jpeg", "image/jpeg",
4261           "realm", "MiniServ",
4262           "session_login", "/session_login.cgi",
4263           "pam_login", "/pam_login.cgi",
4264           "password_form", "/password_form.cgi",
4265           "password_change", "/password_change.cgi",
4266           "maxconns", 50,
4267           "pam", "webmin",
4268           "sidname", "sid",
4269           "unauth", "^/unauthenticated/ ^/robots.txt\$ ^[A-Za-z0-9\\-/_]+\\.jar\$ ^[A-Za-z0-9\\-/_]+\\.class\$ ^[A-Za-z0-9\\-/_]+\\.gif\$ ^[A-Za-z0-9\\-/_]+\\.png\$ ^[A-Za-z0-9\\-/_]+\\.conf\$ ^[A-Za-z0-9\\-/_]+\\.ico\$ ^/robots.txt\$",
4270           "max_post", 10000,
4271           "expires", 7*24*60*60,
4272           "pam_test_user", "root",
4273           "precache", "lang/en */lang/en",
4274          );
4275 foreach my $v (keys %vital) {
4276         if (!$config{$v}) {
4277                 if ($vital{$v} eq "") {
4278                         die "Missing config option $v";
4279                         }
4280                 $config{$v} = $vital{$v};
4281                 }
4282         }
4283 if (!$config{'sessiondb'}) {
4284         $config{'pidfile'} =~ /^(.*)\/[^\/]+$/;
4285         $config{'sessiondb'} = "$1/sessiondb";
4286         }
4287 if (!$config{'errorlog'}) {
4288         $config{'logfile'} =~ /^(.*)\/[^\/]+$/;
4289         $config{'errorlog'} = "$1/miniserv.error";
4290         }
4291 if (!$config{'tempbase'}) {
4292         $config{'pidfile'} =~ /^(.*)\/[^\/]+$/;
4293         $config{'tempbase'} = "$1/cgitemp";
4294         }
4295 if (!$config{'blockedfile'}) {
4296         $config{'pidfile'} =~ /^(.*)\/[^\/]+$/;
4297         $config{'blockedfile'} = "$1/blocked";
4298         }
4299 if (!$config{'webmincron_dir'}) {
4300         $config_file =~ /^(.*)\/[^\/]+$/;
4301         $config{'webmincron_dir'} = "$1/webmincron/crons";
4302         }
4303 if (!$config{'webmincron_last'}) {
4304         $config{'logfile'} =~ /^(.*)\/[^\/]+$/;
4305         $config{'webmincron_last'} = "$1/miniserv.lastcrons";
4306         }
4307 if (!$config{'webmincron_wrapper'}) {
4308         $config{'webmincron_wrapper'} = $config{'root'}.
4309                                         "/webmincron/webmincron.pl";
4310         }
4311 }
4312
4313 # read_users_file()
4314 # Fills the %users and %certs hashes from the users file in %config
4315 sub read_users_file
4316 {
4317 undef(%users);
4318 undef(%certs);
4319 undef(%allow);
4320 undef(%deny);
4321 undef(%allowdays);
4322 undef(%allowhours);
4323 undef(%lastchanges);
4324 undef(%nochange);
4325 undef(%temppass);
4326 if ($config{'userfile'}) {
4327         open(USERS, $config{'userfile'});
4328         while(<USERS>) {
4329                 s/\r|\n//g;
4330                 local @user = split(/:/, $_, -1);
4331                 $users{$user[0]} = $user[1];
4332                 $certs{$user[0]} = $user[3] if ($user[3]);
4333                 if ($user[4] =~ /^allow\s+(.*)/) {
4334                         $allow{$user[0]} = $config{'alwaysresolve'} ?
4335                                 [ split(/\s+/, $1) ] :
4336                                 [ &to_ipaddress(split(/\s+/, $1)) ];
4337                         }
4338                 elsif ($user[4] =~ /^deny\s+(.*)/) {
4339                         $deny{$user[0]} = $config{'alwaysresolve'} ?
4340                                 [ split(/\s+/, $1) ] :
4341                                 [ &to_ipaddress(split(/\s+/, $1)) ];
4342                         }
4343                 if ($user[5] =~ /days\s+(\S+)/) {
4344                         $allowdays{$user[0]} = [ split(/,/, $1) ];
4345                         }
4346                 if ($user[5] =~ /hours\s+(\d+)\.(\d+)-(\d+).(\d+)/) {
4347                         $allowhours{$user[0]} = [ $1*60+$2, $3*60+$4 ];
4348                         }
4349                 $lastchanges{$user[0]} = $user[6];
4350                 $nochange{$user[0]} = $user[9];
4351                 $temppass{$user[0]} = $user[10];
4352                 }
4353         close(USERS);
4354         }
4355
4356 # Test user DB, if configured
4357 if ($config{'userdb'}) {
4358         my $dbh = &connect_userdb($config{'userdb'});
4359         if (!ref($dbh)) {
4360                 print STDERR "Failed to open users database : $dbh\n"
4361                 }
4362         else {
4363                 &disconnect_userdb($config{'userdb'}, $dbh);
4364                 }
4365         }
4366 }
4367
4368 # get_user_details(username)
4369 # Returns a hash ref of user details, either from config files or the user DB
4370 sub get_user_details
4371 {
4372 my ($username) = @_;
4373 if (exists($users{$username})) {
4374         # In local files
4375         return { 'name' => $username,
4376                  'pass' => $users{$username},
4377                  'certs' => $certs{$username},
4378                  'allow' => $allow{$username},
4379                  'deny' => $deny{$username},
4380                  'allowdays' => $allowdays{$username},
4381                  'allowhours' => $allowhours{$username},
4382                  'lastchanges' => $lastchanges{$username},
4383                  'nochange' => $nochange{$username},
4384                  'temppass' => $temppass{$username},
4385                  'preroot' => $config{'preroot_'.$username},
4386                };
4387         }
4388 if ($config{'userdb'}) {
4389         # Try querying user database
4390         if (exists($get_user_details_cache{$username})) {
4391                 # Cached already
4392                 return $get_user_details_cache{$username};
4393                 }
4394         print DEBUG "get_user_details: Connecting to user database\n";
4395         my ($dbh, $proto, $prefix, $args) = &connect_userdb($config{'userdb'});
4396         my $user;
4397         my %attrs;
4398         if (!ref($dbh)) {
4399                 print DEBUG "get_user_details: Failed : $dbh\n";
4400                 print STDERR "Failed to connect to user database : $dbh\n";
4401                 }
4402         elsif ($proto eq "mysql" || $proto eq "postgresql") {
4403                 # Fetch user ID and password with SQL
4404                 print DEBUG "get_user_details: Looking for $username in SQL\n";
4405                 my $cmd = $dbh->prepare(
4406                         "select id,pass from webmin_user where name = ?");
4407                 if (!$cmd || !$cmd->execute($username)) {
4408                         print STDERR "Failed to lookup user : ",
4409                                      $dbh->errstr,"\n";
4410                         return undef;
4411                         }
4412                 my ($id, $pass) = $cmd->fetchrow();
4413                 $cmd->finish();
4414                 if (!$id) {
4415                         &disconnect_userdb($config{'userdb'}, $dbh);
4416                         $get_user_details_cache{$username} = undef;
4417                         print DEBUG "get_user_details: User not found\n";
4418                         return undef;
4419                         }
4420                 print DEBUG "get_user_details: id=$id pass=$pass\n";
4421
4422                 # Fetch attributes and add to user object
4423                 print DEBUG "get_user_details: finding user attributes\n";
4424                 my $cmd = $dbh->prepare(
4425                         "select attr,value from webmin_user_attr where id = ?");
4426                 if (!$cmd || !$cmd->execute($id)) {
4427                         print STDERR "Failed to lookup user attrs : ",
4428                                      $dbh->errstr,"\n";
4429                         return undef;
4430                         }
4431                 $user = { 'name' => $username,
4432                           'id' => $id,
4433                           'pass' => $pass,
4434                           'proto' => $proto };
4435                 while(my ($attr, $value) = $cmd->fetchrow()) {
4436                         $attrs{$attr} = $value;
4437                         }
4438                 $cmd->finish();
4439                 }
4440         elsif ($proto eq "ldap") {
4441                 # Fetch user DN with LDAP
4442                 print DEBUG "get_user_details: Looking for $username in LDAP\n";
4443                 my $rv = $dbh->search(
4444                         base => $prefix,
4445                         filter => '(&(cn='.$username.')(objectClass='.
4446                                   $args->{'userclass'}.'))',
4447                         scope => 'sub');
4448                 if (!$rv || $rv->code) {
4449                         print STDERR "Failed to lookup user : ",
4450                                      ($rv ? $rv->error : "Unknown error"),"\n";
4451                         return undef;
4452                         }
4453                 my ($u) = $rv->all_entries();
4454                 if (!$u) {
4455                         &disconnect_userdb($config{'userdb'}, $dbh);
4456                         $get_user_details_cache{$username} = undef;
4457                         print DEBUG "get_user_details: User not found\n";
4458                         return undef;
4459                         }
4460
4461                 # Extract attributes
4462                 my $pass = $u->get_value('webminPass');
4463                 $user = { 'name' => $username,
4464                           'id' => $u->dn(),
4465                           'pass' => $pass,
4466                           'proto' => $proto };
4467                 foreach my $la ($u->get_value('webminAttr')) {
4468                         my ($attr, $value) = split(/=/, $la, 2);
4469                         $attrs{$attr} = $value;
4470                         }
4471                 }
4472
4473         # Convert DB attributes into user object fields
4474         if ($user) {
4475                 print DEBUG "get_user_details: got ",scalar(keys %attrs),
4476                             " attributes\n";
4477                 $user->{'certs'} = $attrs{'cert'};
4478                 if ($attrs{'allow'}) {
4479                         $user->{'allow'} = $config{'alwaysresolve'} ?
4480                                 [ split(/\s+/, $attrs{'allow'}) ] :
4481                                 [ &to_ipaddress(split(/\s+/,$attrs{'allow'})) ];
4482                         }
4483                 if ($attrs{'deny'}) {
4484                         $user->{'deny'} = $config{'alwaysresolve'} ?
4485                                 [ split(/\s+/, $attrs{'deny'}) ] :
4486                                 [ &to_ipaddress(split(/\s+/,$attrs{'deny'})) ];
4487                         }
4488                 if ($attrs{'days'}) {
4489                         $user->{'allowdays'} = [ split(/,/, $attrs{'days'}) ];
4490                         }
4491                 if ($attrs{'hoursfrom'} && $attrs{'hoursto'}) {
4492                         my ($hf, $mf) = split(/\./, $attrs{'hoursfrom'});
4493                         my ($ht, $mt) = split(/\./, $attrs{'hoursto'});
4494                         $user->{'allowhours'} = [ $hf*60+$ht, $ht*60+$mt ];
4495                         }
4496                 $user->{'lastchanges'} = $attrs{'lastchange'};
4497                 $user->{'nochange'} = $attrs{'nochange'};
4498                 $user->{'temppass'} = $attrs{'temppass'};
4499                 $user->{'preroot'} = $attrs{'theme'};
4500                 }
4501         &disconnect_userdb($config{'userdb'}, $dbh);
4502         $get_user_details_cache{$user->{'name'}} = $user;
4503         return $user;
4504         }
4505 return undef;
4506 }
4507
4508 # find_user_by_cert(cert)
4509 # Returns a username looked up by certificate
4510 sub find_user_by_cert
4511 {
4512 my ($peername) = @_;
4513 my $peername2 = $peername;
4514 $peername2 =~ s/Email=/emailAddress=/ || $peername2 =~ s/emailAddress=/Email=/;
4515
4516 # First check users in local files
4517 foreach my $username (keys %certs) {
4518         if ($certs{$username} eq $peername ||
4519             $certs{$username} eq $peername2) {
4520                 return $username;
4521                 }
4522         }
4523
4524 # Check user DB
4525 if ($config{'userdb'}) {
4526         my ($dbh, $proto) = &connect_userdb($config{'userdb'});
4527         if (!ref($dbh)) {
4528                 return undef;
4529                 }
4530         elsif ($proto eq "mysql" || $proto eq "postgresql") {
4531                 # Query with SQL
4532                 my $cmd = $dbh->prepare("select webmin_user.name from webmin_user,webmin_user_attr where webmin_user.id = webmin_user_attr.id and webmin_user_attr.attr = 'cert' and webmin_user_attr.value = ?");
4533                 return undef if (!$cmd);
4534                 foreach my $p ($peername, $peername2) {
4535                         my $username;
4536                         if ($cmd->execute($p)) {
4537                                 ($username) = $cmd->fetchrow();
4538                                 }
4539                         $cmd->finish();
4540                         return $username if ($username);
4541                         }
4542                 }
4543         elsif ($proto eq "ldap") {
4544                 # Lookup in LDAP
4545                 my $rv = $dbh->search(
4546                         base => $prefix,
4547                         filter => '(objectClass='.
4548                                   $args->{'userclass'}.')',
4549                         scope => 'sub',
4550                         attrs => [ 'cn', 'webminAttr' ]);
4551                 if ($rv && !$rv->code) {
4552                         foreach my $u ($rv->all_entries) {
4553                                 my @attrs = $u->get_value('webminAttr');
4554                                 foreach my $la (@attrs) {
4555                                         my ($attr, $value) = split(/=/, $la, 2);
4556                                         if ($attr eq "cert" &&
4557                                             ($value eq $peername ||
4558                                              $value eq $peername2)) {
4559                                                 return $u->get_value('cn');
4560                                                 }
4561                                         }
4562                                 }
4563                         }
4564                 }
4565         }
4566 return undef;
4567 }
4568
4569 # connect_userdb(string)
4570 # Returns a handle for talking to a user database - may be a DBI or LDAP handle.
4571 # On failure returns an error message string. In an array context, returns the
4572 # protocol type too.
4573 sub connect_userdb
4574 {
4575 my ($str) = @_;
4576 my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
4577 if ($proto eq "mysql") {
4578         # Connect to MySQL with DBI
4579         my $drh = eval "use DBI; DBI->install_driver('mysql');";
4580         $drh || return $text{'sql_emysqldriver'};
4581         my ($host, $port) = split(/:/, $host);
4582         my $cstr = "database=$prefix;host=$host";
4583         $cstr .= ";port=$port" if ($port);
4584         print DEBUG "connect_userdb: Connecting to MySQL $cstr as $user\n";
4585         my $dbh = $drh->connect($cstr, $user, $pass, { });
4586         $dbh || return &text('sql_emysqlconnect', $drh->errstr);
4587         print DEBUG "connect_userdb: Connected OK\n";
4588         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
4589         }
4590 elsif ($proto eq "postgresql") {
4591         # Connect to PostgreSQL with DBI
4592         my $drh = eval "use DBI; DBI->install_driver('Pg');";
4593         $drh || return $text{'sql_epostgresqldriver'};
4594         my ($host, $port) = split(/:/, $host);
4595         my $cstr = "dbname=$prefix;host=$host";
4596         $cstr .= ";port=$port" if ($port);
4597         print DEBUG "connect_userdb: Connecting to PostgreSQL $cstr as $user\n";
4598         my $dbh = $drh->connect($cstr, $user, $pass);
4599         $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
4600         print DEBUG "connect_userdb: Connected OK\n";
4601         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
4602         }
4603 elsif ($proto eq "ldap") {
4604         # Connect with perl LDAP module
4605         eval "use Net::LDAP";
4606         $@ && return $text{'sql_eldapdriver'};
4607         my ($host, $port) = split(/:/, $host);
4608         my $scheme = $args->{'scheme'} || 'ldap';
4609         if (!$port) {
4610                 $port = $scheme eq 'ldaps' ? 636 : 389;
4611                 }
4612         my $ldap = Net::LDAP->new($host,
4613                                   port => $port,
4614                                   'scheme' => $scheme);
4615         $ldap || return &text('sql_eldapconnect', $host);
4616         my $mesg;
4617         if ($args->{'tls'}) {
4618                 # Switch to TLS mode
4619                 eval { $mesg = $ldap->start_tls(); };
4620                 if ($@ || !$mesg || $mesg->code) {
4621                         return &text('sql_eldaptls',
4622                             $@ ? $@ : $mesg ? $mesg->error : "Unknown error");
4623                         }
4624                 }
4625         # Login to the server
4626         if ($pass) {
4627                 $mesg = $ldap->bind(dn => $user, password => $pass);
4628                 }
4629         else {
4630                 $mesg = $ldap->bind(dn => $user, anonymous => 1);
4631                 }
4632         if (!$mesg || $mesg->code) {
4633                 return &text('sql_eldaplogin', $user,
4634                              $mesg ? $mesg->error : "Unknown error");
4635                 }
4636         return wantarray ? ($ldap, $proto, $prefix, $args) : $ldap;
4637         }
4638 else {
4639         return "Unknown protocol $proto";
4640         }
4641 }
4642
4643 # split_userdb_string(string)
4644 # Converts a string like mysql://user:pass@host/db into separate parts
4645 sub split_userdb_string
4646 {
4647 my ($str) = @_;
4648 if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
4649         my ($proto, $user, $pass, $host, $prefix, $argstr) =
4650                 ($1, $2, $3, $4, $5, $7);
4651         my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
4652         return ($proto, $user, $pass, $host, $prefix, \%args);
4653         }
4654 return ( );
4655 }
4656
4657 # disconnect_userdb(string, &handle)
4658 # Closes a handle opened by connect_userdb
4659 sub disconnect_userdb
4660 {
4661 my ($str, $h) = @_;
4662 if ($str =~ /^(mysql|postgresql):/) {
4663         # DBI disconnnect
4664         $h->disconnect();
4665         }
4666 elsif ($str =~ /^ldap:/) {
4667         # LDAP disconnect
4668         $h->disconnect();
4669         }
4670 }
4671
4672 # read_mime_types()
4673 # Fills %mime with entries from file in %config and extra settings in %config
4674 sub read_mime_types
4675 {
4676 undef(%mime);
4677 if ($config{"mimetypes"} ne "") {
4678         open(MIME, $config{"mimetypes"});
4679         while(<MIME>) {
4680                 chop; s/#.*$//;
4681                 if (/^(\S+)\s+(.*)$/) {
4682                         my $type = $1;
4683                         my @exts = split(/\s+/, $2);
4684                         foreach my $ext (@exts) {
4685                                 $mime{$ext} = $type;
4686                                 }
4687                         }
4688                 }
4689         close(MIME);
4690         }
4691 foreach my $k (keys %config) {
4692         if ($k !~ /^addtype_(.*)$/) { next; }
4693         $mime{$1} = $config{$k};
4694         }
4695 }
4696
4697 # build_config_mappings()
4698 # Build the anonymous access list, IP access list, unauthenticated URLs list,
4699 # redirect mapping and allow and deny lists from %config
4700 sub build_config_mappings
4701 {
4702 # build anonymous access list
4703 undef(%anonymous);
4704 foreach my $a (split(/\s+/, $config{'anonymous'})) {
4705         if ($a =~ /^([^=]+)=(\S+)$/) {
4706                 $anonymous{$1} = $2;
4707                 }
4708         }
4709
4710 # build IP access list
4711 undef(%ipaccess);
4712 foreach my $a (split(/\s+/, $config{'ipaccess'})) {
4713         if ($a =~ /^([^=]+)=(\S+)$/) {
4714                 $ipaccess{$1} = $2;
4715                 }
4716         }
4717
4718 # build unauthenticated URLs list
4719 @unauth = split(/\s+/, $config{'unauth'});
4720
4721 # build redirect mapping
4722 undef(%redirect);
4723 foreach my $r (split(/\s+/, $config{'redirect'})) {
4724         if ($r =~ /^([^=]+)=(\S+)$/) {
4725                 $redirect{$1} = $2;
4726                 }
4727         }
4728
4729 # build prefixes to be stripped
4730 undef(@strip_prefix);
4731 foreach my $r (split(/\s+/, $config{'strip_prefix'})) {
4732         push(@strip_prefix, $r);
4733         }
4734
4735 # Init allow and deny lists
4736 @deny = split(/\s+/, $config{"deny"});
4737 @deny = &to_ipaddress(@deny) if (!$config{'alwaysresolve'});
4738 @allow = split(/\s+/, $config{"allow"});
4739 @allow = &to_ipaddress(@allow) if (!$config{'alwaysresolve'});
4740 undef(@allowusers);
4741 undef(@denyusers);
4742 if ($config{'allowusers'}) {
4743         @allowusers = split(/\s+/, $config{'allowusers'});
4744         }
4745 elsif ($config{'denyusers'}) {
4746         @denyusers = split(/\s+/, $config{'denyusers'});
4747         }
4748
4749 # Build list of unixauth mappings
4750 undef(%unixauth);
4751 foreach my $ua (split(/\s+/, $config{'unixauth'})) {
4752         if ($ua =~ /^(\S+)=(\S+)$/) {
4753                 $unixauth{$1} = $2;
4754                 }
4755         else {
4756                 $unixauth{"*"} = $ua;
4757                 }
4758         }
4759
4760 # Build list of non-session-auth pages
4761 undef(%sessiononly);
4762 foreach my $sp (split(/\s+/, $config{'sessiononly'})) {
4763         $sessiononly{$sp} = 1;
4764         }
4765
4766 # Build list of logout times
4767 undef(@logouttimes);
4768 foreach my $a (split(/\s+/, $config{'logouttimes'})) {
4769         if ($a =~ /^([^=]+)=(\S+)$/) {
4770                 push(@logouttimes, [ $1, $2 ]);
4771                 }
4772         }
4773 push(@logouttimes, [ undef, $config{'logouttime'} ]);
4774
4775 # Build list of DAV pathss
4776 undef(@davpaths);
4777 foreach my $d (split(/\s+/, $config{'davpaths'})) {
4778         push(@davpaths, $d);
4779         }
4780 @davusers = split(/\s+/, $config{'dav_users'});
4781
4782 # Mobile agent substrings and hostname prefixes
4783 @mobile_agents = split(/\t+/, $config{'mobile_agents'});
4784 @mobile_prefixes = split(/\s+/, $config{'mobile_prefixes'});
4785
4786 # Expires time list
4787 @expires_paths = ( );
4788 foreach my $pe (split(/\t+/, $config{'expires_paths'})) {
4789         my ($p, $e) = split(/=/, $pe);
4790         if ($p && $e ne '') {
4791                 push(@expires_paths, [ $p, $e ]);
4792                 }
4793         }
4794
4795 # Open debug log
4796 close(DEBUG);
4797 if ($config{'debug'}) {
4798         open(DEBUG, ">>$config{'debug'}");
4799         }
4800 else {
4801         open(DEBUG, ">/dev/null");
4802         }
4803
4804 # Reset cache of sudo checks
4805 undef(%sudocache);
4806 }
4807
4808 # is_group_member(&uinfo, groupname)
4809 # Returns 1 if some user is a primary or secondary member of a group
4810 sub is_group_member
4811 {
4812 local ($uinfo, $group) = @_;
4813 local @ginfo = getgrnam($group);
4814 return 0 if (!@ginfo);
4815 return 1 if ($ginfo[2] == $uinfo->[3]); # primary member
4816 foreach my $m (split(/\s+/, $ginfo[3])) {
4817         return 1 if ($m eq $uinfo->[0]);
4818         }
4819 return 0;
4820 }
4821
4822 # prefix_to_mask(prefix)
4823 # Converts a number like 24 to a mask like 255.255.255.0
4824 sub prefix_to_mask
4825 {
4826 return $_[0] >= 24 ? "255.255.255.".(256-(2 ** (32-$_[0]))) :
4827        $_[0] >= 16 ? "255.255.".(256-(2 ** (24-$_[0]))).".0" :
4828        $_[0] >= 8 ? "255.".(256-(2 ** (16-$_[0]))).".0.0" :
4829                      (256-(2 ** (8-$_[0]))).".0.0.0";
4830 }
4831
4832 # get_logout_time(user, session-id)
4833 # Given a username, returns the idle time before he will be logged out
4834 sub get_logout_time
4835 {
4836 local ($user, $sid) = @_;
4837 if (!defined($logout_time_cache{$user,$sid})) {
4838         local $time;
4839         foreach my $l (@logouttimes) {
4840                 if ($l->[0] =~ /^\@(.*)$/) {
4841                         # Check group membership
4842                         local @uinfo = getpwnam($user);
4843                         if (@uinfo && &is_group_member(\@uinfo, $1)) {
4844                                 $time = $l->[1];
4845                                 }
4846                         }
4847                 elsif ($l->[0] =~ /^\//) {
4848                         # Check file contents
4849                         open(FILE, $l->[0]);
4850                         while(<FILE>) {
4851                                 s/\r|\n//g;
4852                                 s/^\s*#.*$//;
4853                                 if ($user eq $_) {
4854                                         $time = $l->[1];
4855                                         last;
4856                                         }
4857                                 }
4858                         close(FILE);
4859                         }
4860                 elsif (!$l->[0]) {
4861                         # Always match
4862                         $time = $l->[1];
4863                         }
4864                 else {
4865                         # Check username
4866                         if ($l->[0] eq $user) {
4867                                 $time = $l->[1];
4868                                 }
4869                         }
4870                 last if (defined($time));
4871                 }
4872         $logout_time_cache{$user,$sid} = $time;
4873         }
4874 return $logout_time_cache{$user,$sid};
4875 }
4876
4877 # password_crypt(password, salt)
4878 # If the salt looks like MD5 and we have a library for it, perform MD5 hashing
4879 # of a password. Otherwise, do Unix crypt.
4880 sub password_crypt
4881 {
4882 local ($pass, $salt) = @_;
4883 if ($salt =~ /^\$1\$/ && $use_md5) {
4884         return &encrypt_md5($pass, $salt);
4885         }
4886 else {
4887         return &unix_crypt($pass, $salt);
4888         }
4889 }
4890
4891 # unix_crypt(password, salt)
4892 # Performs standard Unix hashing for a password
4893 sub unix_crypt
4894 {
4895 local ($pass, $salt) = @_;
4896 if ($use_perl_crypt) {
4897         return Crypt::UnixCrypt::crypt($pass, $salt);
4898         }
4899 else {
4900         return crypt($pass, $salt);
4901         }
4902 }
4903
4904 # handle_dav_request(davpath)
4905 # Pass a request on to the Net::DAV::Server module
4906 sub handle_dav_request
4907 {
4908 local ($path) = @_;
4909 eval "use Filesys::Virtual::Plain";
4910 eval "use Net::DAV::Server";
4911 eval "use HTTP::Request";
4912 eval "use HTTP::Headers";
4913
4914 if ($Net::DAV::Server::VERSION eq '1.28' && $config{'dav_nolock'}) {
4915         delete $Net::DAV::Server::implemented{lock};
4916         delete $Net::DAV::Server::implemented{unlock};
4917         }
4918
4919 # Read in request data
4920 if (!$posted_data) {
4921         local $clen = $header{"content-length"};
4922         while(length($posted_data) < $clen) {
4923                 $buf = &read_data($clen - length($posted_data));
4924                 if (!length($buf)) {
4925                         &http_error(500, "Failed to read POST request");
4926                         }
4927                 $posted_data .= $buf;
4928                 }
4929         }
4930
4931 # For subsequent logging
4932 open(MINISERVLOG, ">>$config{'logfile'}");
4933
4934 # Switch to user
4935 local $root;
4936 local @u = getpwnam($authuser);
4937 if ($config{'dav_remoteuser'} && !$< && $validated) {
4938         if (@u) {
4939                 if ($u[2] != 0) {
4940                         $( = $u[3]; $) = "$u[3] $u[3]";
4941                         ($>, $<) = ($u[2], $u[2]);
4942                         }
4943                 if ($config{'dav_root'} eq '*') {
4944                         $root = $u[7];
4945                         }
4946                 }
4947         else {
4948                 &http_error(500, "Unix user $authuser does not exist");
4949                 return 0;
4950                 }
4951         }
4952 $root ||= $config{'dav_root'};
4953 $root ||= "/";
4954
4955 # Check if this user can use DAV
4956 if (@davusers) {
4957         &users_match(\@u, @davusers) ||
4958                 &http_error(500, "You are not allowed to access DAV");
4959         }
4960
4961 # Create DAV server
4962 my $filesys = Filesys::Virtual::Plain->new({root_path => $root});
4963 my $webdav = Net::DAV::Server->new();
4964 $webdav->filesys($filesys);
4965
4966 # Make up a request object, and feed to DAV
4967 local $ho = HTTP::Headers->new;
4968 foreach my $h (keys %header) {
4969         next if (lc($h) eq "connection");
4970         $ho->header($h => $header{$h});
4971         }
4972 if ($path ne "/") {
4973         $request_uri =~ s/^\Q$path\E//;
4974         $request_uri = "/" if ($request_uri eq "");
4975         }
4976 my $request = HTTP::Request->new($method, $request_uri, $ho,
4977                                  $posted_data);
4978 if ($config{'dav_debug'}) {
4979         print STDERR "DAV request :\n";
4980         print STDERR "---------------------------------------------\n";
4981         print STDERR $request->as_string();
4982         print STDERR "---------------------------------------------\n";
4983         }
4984 my $response = $webdav->run($request);
4985
4986 # Send back the reply
4987 &write_data("HTTP/1.1 ",$response->code()," ",$response->message(),"\r\n");
4988 local $content = $response->content();
4989 if ($path ne "/") {
4990         $content =~ s|href>/(.+)<|href>$path/$1<|g;
4991         $content =~ s|href>/<|href>$path<|g;
4992         }
4993 foreach my $h ($response->header_field_names) {
4994         next if (lc($h) eq "connection" || lc($h) eq "content-length");
4995         &write_data("$h: ",$response->header($h),"\r\n");
4996         }
4997 &write_data("Content-length: ",length($content),"\r\n");
4998 local $rv = &write_keep_alive(0);
4999 &write_data("\r\n");
5000 &write_data($content);
5001
5002 if ($config{'dav_debug'}) {
5003         print STDERR "DAV reply :\n";
5004         print STDERR "---------------------------------------------\n";
5005         print STDERR "HTTP/1.1 ",$response->code()," ",$response->message(),"\r\n";
5006         foreach my $h ($response->header_field_names) {
5007                 next if (lc($h) eq "connection" || lc($h) eq "content-length");
5008                 print STDERR "$h: ",$response->header($h),"\r\n";
5009                 }
5010         print STDERR "Content-length: ",length($content),"\r\n";
5011         print STDERR "\r\n";
5012         print STDERR $content;
5013         print STDERR "---------------------------------------------\n";
5014         }
5015
5016 # Log it
5017 &log_request($acpthost, $authuser, $reqline, $response->code(),
5018              length($response->content()));
5019 }
5020
5021 # get_system_hostname()
5022 # Returns the hostname of this system, for reporting to listeners
5023 sub get_system_hostname
5024 {
5025 # On Windows, try computername environment variable
5026 return $ENV{'computername'} if ($ENV{'computername'});
5027 return $ENV{'COMPUTERNAME'} if ($ENV{'COMPUTERNAME'});
5028
5029 # If a specific command is set, use it first
5030 if ($config{'hostname_command'}) {
5031         local $out = `($config{'hostname_command'}) 2>&1`;
5032         if (!$?) {
5033                 $out =~ s/\r|\n//g;
5034                 return $out;
5035                 }
5036         }
5037
5038 # First try the hostname command
5039 local $out = `hostname 2>&1`;
5040 if (!$? && $out =~ /\S/) {
5041         $out =~ s/\r|\n//g;
5042         return $out;
5043         }
5044
5045 # Try the Sys::Hostname module
5046 eval "use Sys::Hostname";
5047 if (!$@) {
5048         local $rv = eval "hostname()";
5049         if (!$@ && $rv) {
5050                 return $rv;
5051                 }
5052         }
5053
5054 # Must use net name on Windows
5055 local $out = `net name 2>&1`;
5056 if ($out =~ /\-+\r?\n(\S+)/) {
5057         return $1;
5058         }
5059
5060 return undef;
5061 }
5062
5063 # indexof(string, array)
5064 # Returns the index of some value in an array, or -1
5065 sub indexof {
5066   local($i);
5067   for($i=1; $i <= $#_; $i++) {
5068     if ($_[$i] eq $_[0]) { return $i - 1; }
5069   }
5070   return -1;
5071 }
5072
5073
5074 # has_command(command)
5075 # Returns the full path if some command is in the path, undef if not
5076 sub has_command
5077 {
5078 local($d);
5079 if (!$_[0]) { return undef; }
5080 if (exists($has_command_cache{$_[0]})) {
5081         return $has_command_cache{$_[0]};
5082         }
5083 local $rv = undef;
5084 if ($_[0] =~ /^\//) {
5085         $rv = -x $_[0] ? $_[0] : undef;
5086         }
5087 else {
5088         local $sp = $on_windows ? ';' : ':';
5089         foreach $d (split($sp, $ENV{PATH})) {
5090                 if (-x "$d/$_[0]") {
5091                         $rv = "$d/$_[0]";
5092                         last;
5093                         }
5094                 if ($on_windows) {
5095                         foreach my $sfx (".exe", ".com", ".bat") {
5096                                 if (-r "$d/$_[0]".$sfx) {
5097                                         $rv = "$d/$_[0]".$sfx;
5098                                         last;
5099                                         }
5100                                 }
5101                         }
5102                 }
5103         }
5104 $has_command_cache{$_[0]} = $rv;
5105 return $rv;
5106 }
5107
5108 # check_sudo_permissions(user, pass)
5109 # Returns 1 if some user can run any command via sudo
5110 sub check_sudo_permissions
5111 {
5112 local ($user, $pass) = @_;
5113
5114 # First try the pipes
5115 if ($PASSINw) {
5116         print DEBUG "check_sudo_permissions: querying cache for $user\n";
5117         print $PASSINw "readsudo $user\n";
5118         local $can = <$PASSOUTr>;
5119         chop($can);
5120         print DEBUG "check_sudo_permissions: cache said $can\n";
5121         if ($can =~ /^\d+$/ && $can != 2) {
5122                 return int($can);
5123                 }
5124         }
5125
5126 local $ptyfh = new IO::Pty;
5127 print DEBUG "check_sudo_permissions: ptyfh=$ptyfh\n";
5128 if (!$ptyfh) {
5129         print STDERR "Failed to create new PTY with IO::Pty\n";
5130         return 0;
5131         }
5132 local @uinfo = getpwnam($user);
5133 if (!@uinfo) {
5134         print STDERR "Unix user $user does not exist for sudo\n";
5135         return 0;
5136         }
5137
5138 # Execute sudo in a sub-process, via a pty
5139 local $ttyfh = $ptyfh->slave();
5140 print DEBUG "check_sudo_permissions: ttyfh=$ttyfh\n";
5141 local $tty = $ptyfh->ttyname();
5142 print DEBUG "check_sudo_permissions: tty=$tty\n";
5143 chown($uinfo[2], $uinfo[3], $tty);
5144 pipe(SUDOr, SUDOw);
5145 print DEBUG "check_sudo_permissions: about to fork..\n";
5146 local $pid = fork();
5147 print DEBUG "check_sudo_permissions: fork=$pid pid=$$\n";
5148 if ($pid < 0) {
5149         print STDERR "fork for sudo failed : $!\n";
5150         return 0;
5151         }
5152 if (!$pid) {
5153         setsid();
5154         $ptyfh->make_slave_controlling_terminal();
5155         close(STDIN); close(STDOUT); close(STDERR);
5156         untie(*STDIN); untie(*STDOUT); untie(*STDERR);
5157         close($PASSINw); close($PASSOUTr);
5158         $( = $uinfo[3]; $) = "$uinfo[3] $uinfo[3]";
5159         ($>, $<) = ($uinfo[2], $uinfo[2]);
5160
5161         close(SUDOw);
5162         close(SOCK);
5163         close(MAIN);
5164         open(STDIN, "<&SUDOr");
5165         open(STDOUT, ">$tty");
5166         open(STDERR, ">&STDOUT");
5167         close($ptyfh);
5168         exec("sudo -l -S");
5169         print "Exec failed : $!\n";
5170         exit 1;
5171         }
5172 print DEBUG "check_sudo_permissions: pid=$pid\n";
5173 close(SUDOr);
5174 $ptyfh->close_slave();
5175
5176 # Send password, and get back response
5177 local $oldfh = select(SUDOw);
5178 $| = 1;
5179 select($oldfh);
5180 print DEBUG "check_sudo_permissions: about to send pass\n";
5181 local $SIG{'PIPE'} = 'ignore';  # Sometimes sudo doesn't ask for a password
5182 print SUDOw $pass,"\n";
5183 print DEBUG "check_sudo_permissions: sent pass=$pass\n";
5184 close(SUDOw);
5185 local $out;
5186 while(<$ptyfh>) {
5187         print DEBUG "check_sudo_permissions: got $_";
5188         $out .= $_;
5189         }
5190 close($ptyfh);
5191 kill('KILL', $pid);
5192 waitpid($pid, 0);
5193 local ($ok) = ($out =~ /\(ALL\)\s+ALL|\(ALL\)\s+NOPASSWD:\s+ALL/ ? 1 : 0);
5194
5195 # Update cache
5196 if ($PASSINw) {
5197         print $PASSINw "writesudo $user $ok\n";
5198         }
5199
5200 return $ok;
5201 }
5202
5203 # is_mobile_useragent(agent)
5204 # Returns 1 if some user agent looks like a cellphone or other mobile device,
5205 # such as a treo.
5206 sub is_mobile_useragent
5207 {
5208 local ($agent) = @_;
5209 local @prefixes = (
5210     "UP.Link",    # Openwave
5211     "Nokia",      # All Nokias start with Nokia
5212     "MOT-",       # All Motorola phones start with MOT-
5213     "SAMSUNG",    # Samsung browsers
5214     "Samsung",    # Samsung browsers
5215     "SEC-",       # Samsung browsers
5216     "AU-MIC",     # Samsung browsers
5217     "AUDIOVOX",   # Audiovox
5218     "BlackBerry", # BlackBerry
5219     "hiptop",     # Danger hiptop Sidekick
5220     "SonyEricsson", # Sony Ericsson
5221     "Ericsson",     # Old Ericsson browsers , mostly WAP
5222     "Mitsu/1.1.A",  # Mitsubishi phones
5223     "Panasonic WAP", # Panasonic old WAP phones
5224     "DoCoMo",     # DoCoMo phones
5225     "Lynx",       # Lynx text-mode linux browser
5226     "Links",      # Another text-mode linux browser
5227     );
5228 local @substrings = (
5229     "UP.Browser",         # Openwave
5230     "MobilePhone",        # NetFront
5231     "AU-MIC-A700",        # Samsung A700 Obigo browsers
5232     "Danger hiptop",      # Danger Sidekick hiptop
5233     "Windows CE",         # Windows CE Pocket PC
5234     "IEMobile",           # Windows mobile browser
5235     "Blazer",             # Palm Treo Blazer
5236     "BlackBerry",         # BlackBerries can emulate other browsers, but
5237                           # they still keep this string in the UserAgent
5238     "SymbianOS",          # New Series60 browser has safari in it and
5239                           # SymbianOS is the only distinguishing string
5240     "iPhone",             # Apple iPhone KHTML browser
5241     "iPod",               # iPod touch browser
5242     "MobileSafari",       # HTTP client in iPhone
5243     "Android",            # gPhone
5244     "Opera Mini",         # Opera Mini
5245     "HTC_P3700",          # HTC mobile device
5246     "Pre/",               # Palm Pre
5247     "webOS/",             # Palm WebOS
5248     "Nintendo DS",        # DSi / DSi-XL
5249     );
5250 foreach my $p (@prefixes) {
5251         return 1 if ($agent =~ /^\Q$p\E/);
5252         }
5253 foreach my $s (@substrings, @mobile_agents) {
5254         return 1 if ($agent =~ /\Q$s\E/);
5255         }
5256 return 0;
5257 }
5258
5259 # write_blocked_file()
5260 # Writes out a text file of blocked hosts and users
5261 sub write_blocked_file
5262 {
5263 open(BLOCKED, ">$config{'blockedfile'}");
5264 foreach my $d (grep { $hostfail{$_} } @deny) {
5265         print BLOCKED "host $d $hostfail{$d} $blockhosttime{$d}\n";
5266         }
5267 foreach my $d (grep { $userfail{$_} } @denyusers) {
5268         print BLOCKED "user $d $userfail{$d} $blockusertime{$d}\n";
5269         }
5270 close(BLOCKED);
5271 chmod(0700, $config{'blockedfile'});
5272 }
5273
5274 sub write_pid_file
5275 {
5276 open(PIDFILE, ">$config{'pidfile'}");
5277 printf PIDFILE "%d\n", getpid();
5278 close(PIDFILE);
5279 $miniserv_main_pid = getpid();
5280 }
5281
5282 # lock_user_password(user)
5283 # Updates a user's password file entry to lock it, both in memory and on disk.
5284 # Returns 1 if done, -1 if no such user, 0 if already locked
5285 sub lock_user_password
5286 {
5287 local ($user) = @_;
5288 local $uinfo = &get_user_details($user);
5289 if (!$uinfo) {
5290         # No such user!
5291         return -1;
5292         }
5293 if ($uinfo->{'pass'} =~ /^\!/) {
5294         # Already locked
5295         return 0;
5296         }
5297 if (!$uinfo->{'proto'}) {
5298         # Write to users file
5299         $users{$user} = "!".$users{$user};
5300         open(USERS, $config{'userfile'});
5301         local @ufile = <USERS>;
5302         close(USERS);
5303         foreach my $u (@ufile) {
5304                 local @uinfo = split(/:/, $u);
5305                 if ($uinfo[0] eq $user) {
5306                         $uinfo[1] = $users{$user};
5307                         }
5308                 $u = join(":", @uinfo);
5309                 }
5310         open(USERS, ">$config{'userfile'}");
5311         print USERS @ufile;
5312         close(USERS);
5313         return 0;
5314         }
5315
5316 if ($config{'userdb'}) {
5317         # Update user DB
5318         my ($dbh, $proto, $prefix, $args) = &connect_userdb($config{'userdb'});
5319         if (!$dbh) {
5320                 return -1;
5321                 }
5322         elsif ($proto eq "mysql" || $proto eq "postgresql") {
5323                 # Update user attribute
5324                 my $cmd = $dbh->prepare(
5325                         "update webmin_user set pass = ? where id = ?");
5326                 if (!$cmd || !$cmd->execute("!".$uinfo->{'pass'},
5327                                             $uinfo->{'id'})) {
5328                         # Update failed
5329                         print STDERR "Failed to lock password : ",
5330                                      $dbh->errstr,"\n";
5331                         return -1;
5332                         }
5333                 $cmd->finish() if ($cmd);
5334                 }
5335         elsif ($proto eq "ldap") {
5336                 # Update LDAP object
5337                 my $rv = $dbh->modify($uinfo->{'id'},
5338                       replace => { 'webminPass' => '!'.$uinfo->{'pass'} });
5339                 if (!$rv || $rv->code) {
5340                         print STDERR "Failed to lock password : ",
5341                                      ($rv ? $rv->error : "Unknown error"),"\n";
5342                         return -1;
5343                         }
5344                 }
5345         &disconnect_userdb($config{'userdb'}, $dbh);
5346         return 0;
5347         }
5348
5349 return -1;      # This should never be reached
5350 }
5351
5352 # hash_session_id(sid)
5353 # Returns an MD5 or Unix-crypted session ID
5354 sub hash_session_id
5355 {
5356 local ($sid) = @_;
5357 if (!$hash_session_id_cache{$sid}) {
5358         if ($use_md5) {
5359                 # Take MD5 hash
5360                 $hash_session_id_cache{$sid} = &encrypt_md5($sid);
5361                 }
5362         else {
5363                 # Unix crypt
5364                 $hash_session_id_cache{$sid} = &unix_crypt($sid, "XX");
5365                 }
5366         }
5367 return $hash_session_id_cache{$sid};
5368 }
5369
5370 # encrypt_md5(string, [salt])
5371 # Returns a string encrypted in MD5 format
5372 sub encrypt_md5
5373 {
5374 local ($passwd, $salt) = @_;
5375 local $magic = '$1$';
5376 if ($salt =~ /^\$1\$([^\$]+)/) {
5377         # Extract actual salt from already encrypted password
5378         $salt = $1;
5379         }
5380
5381 # Add the password
5382 local $ctx = eval "new $use_md5";
5383 $ctx->add($passwd);
5384 if ($salt) {
5385         $ctx->add($magic);
5386         $ctx->add($salt);
5387         }
5388
5389 # Add some more stuff from the hash of the password and salt
5390 local $ctx1 = eval "new $use_md5";
5391 $ctx1->add($passwd);
5392 if ($salt) {
5393         $ctx1->add($salt);
5394         }
5395 $ctx1->add($passwd);
5396 local $final = $ctx1->digest();
5397 for($pl=length($passwd); $pl>0; $pl-=16) {
5398         $ctx->add($pl > 16 ? $final : substr($final, 0, $pl));
5399         }
5400
5401 # This piece of code seems rather pointless, but it's in the C code that
5402 # does MD5 in PAM so it has to go in!
5403 local $j = 0;
5404 local ($i, $l);
5405 for($i=length($passwd); $i; $i >>= 1) {
5406         if ($i & 1) {
5407                 $ctx->add("\0");
5408                 }
5409         else {
5410                 $ctx->add(substr($passwd, $j, 1));
5411                 }
5412         }
5413 $final = $ctx->digest();
5414
5415 if ($salt) {
5416         # This loop exists only to waste time
5417         for($i=0; $i<1000; $i++) {
5418                 $ctx1 = eval "new $use_md5";
5419                 $ctx1->add($i & 1 ? $passwd : $final);
5420                 $ctx1->add($salt) if ($i % 3);
5421                 $ctx1->add($passwd) if ($i % 7);
5422                 $ctx1->add($i & 1 ? $final : $passwd);
5423                 $final = $ctx1->digest();
5424                 }
5425         }
5426
5427 # Convert the 16-byte final string into a readable form
5428 local $rv;
5429 local @final = map { ord($_) } split(//, $final);
5430 $l = ($final[ 0]<<16) + ($final[ 6]<<8) + $final[12];
5431 $rv .= &to64($l, 4);
5432 $l = ($final[ 1]<<16) + ($final[ 7]<<8) + $final[13];
5433 $rv .= &to64($l, 4);
5434 $l = ($final[ 2]<<16) + ($final[ 8]<<8) + $final[14];
5435 $rv .= &to64($l, 4);
5436 $l = ($final[ 3]<<16) + ($final[ 9]<<8) + $final[15];
5437 $rv .= &to64($l, 4);
5438 $l = ($final[ 4]<<16) + ($final[10]<<8) + $final[ 5];
5439 $rv .= &to64($l, 4);
5440 $l = $final[11];
5441 $rv .= &to64($l, 2);
5442
5443 # Add salt if needed
5444 if ($salt) {
5445         return $magic.$salt.'$'.$rv;
5446         }
5447 else {
5448         return $rv;
5449         }
5450 }
5451
5452 sub to64
5453 {
5454 local ($v, $n) = @_;
5455 local $r;
5456 while(--$n >= 0) {
5457         $r .= $itoa64[$v & 0x3f];
5458         $v >>= 6;
5459         }
5460 return $r;
5461 }
5462
5463 # read_file(file, &assoc, [&order], [lowercase])
5464 # Fill an associative array with name=value pairs from a file
5465 sub read_file
5466 {
5467 open(ARFILE, $_[0]) || return 0;
5468 while(<ARFILE>) {
5469         s/\r|\n//g;
5470         if (!/^#/ && /^([^=]*)=(.*)$/) {
5471                 $_[1]->{$_[3] ? lc($1) : $1} = $2;
5472                 push(@{$_[2]}, $1) if ($_[2]);
5473                 }
5474         }
5475 close(ARFILE);
5476 return 1;
5477 }
5478
5479 # write_file(file, array)
5480 # Write out the contents of an associative array as name=value lines
5481 sub write_file
5482 {
5483 local(%old, @order);
5484 &read_file($_[0], \%old, \@order);
5485 open(ARFILE, ">$_[0]");
5486 foreach $k (@order) {
5487         print ARFILE $k,"=",$_[1]->{$k},"\n" if (exists($_[1]->{$k}));
5488         }
5489 foreach $k (keys %{$_[1]}) {
5490         print ARFILE $k,"=",$_[1]->{$k},"\n" if (!exists($old{$k}));
5491         }
5492 close(ARFILE);
5493 }
5494
5495 # execute_ready_webmin_crons()
5496 # Find and run any cron jobs that are due, based on their last run time and
5497 # execution interval
5498 sub execute_ready_webmin_crons
5499 {
5500 my $now = time();
5501 my $changed = 0;
5502 foreach my $cron (@webmincrons) {
5503         my $run = 0;
5504         if (!$webmincron_last{$cron->{'id'}}) {
5505                 # If not ever run before, don't run right away
5506                 $webmincron_last{$cron->{'id'}} = $now;
5507                 $changed = 1;
5508                 }
5509         elsif ($cron->{'interval'} &&
5510                $now - $webmincron_last{$cron->{'id'}} > $cron->{'interval'}) {
5511                 # Older than interval .. time to run
5512                 $run = 1;
5513                 }
5514         elsif ($cron->{'mins'}) {
5515                 # Check if current time matches spec, and we haven't run in the
5516                 # last minute
5517                 my @tm = localtime($now);
5518                 if (&matches_cron($cron->{'mins'}, $tm[1]) &&
5519                     &matches_cron($cron->{'hours'}, $tm[2]) &&
5520                     &matches_cron($cron->{'days'}, $tm[3]) &&
5521                     &matches_cron($cron->{'months'}, $tm[4]+1) &&
5522                     &matches_cron($cron->{'weekdays'}, $tm[6]) &&
5523                     $now - $webmincron_last{$cron->{'id'}} > 60) {
5524                         $run = 1;
5525                         }
5526                 }
5527
5528         if ($run) {
5529                 print DEBUG "Running cron id=$cron->{'id'} ".
5530                             "module=$cron->{'module'} func=$cron->{'func'}\n";
5531                 $webmincron_last{$cron->{'id'}} = $now;
5532                 $changed = 1;
5533                 my $pid = fork();
5534                 if (!$pid) {
5535                         # Run via a wrapper command, which we run like a CGI
5536                         dbmclose(%sessiondb);
5537
5538                         # Setup CGI-like environment
5539                         $envtz = $ENV{"TZ"};
5540                         $envuser = $ENV{"USER"};
5541                         $envpath = $ENV{"PATH"};
5542                         $envlang = $ENV{"LANG"};
5543                         $envroot = $ENV{"SystemRoot"};
5544                         $envperllib = $ENV{'PERLLIB'};
5545                         foreach my $k (keys %ENV) {
5546                                 delete($ENV{$k});
5547                                 }
5548                         $ENV{"PATH"} = $envpath if ($envpath);
5549                         $ENV{"TZ"} = $envtz if ($envtz);
5550                         $ENV{"USER"} = $envuser if ($envuser);
5551                         $ENV{"OLD_LANG"} = $envlang if ($envlang);
5552                         $ENV{"SystemRoot"} = $envroot if ($envroot);
5553                         $ENV{'PERLLIB'} = $envperllib if ($envperllib);
5554                         $ENV{"HOME"} = $user_homedir;
5555                         $ENV{"SERVER_SOFTWARE"} = $config{"server"};
5556                         $ENV{"SERVER_ADMIN"} = $config{"email"};
5557                         $root0 = $roots[0];
5558                         $ENV{"SERVER_ROOT"} = $root0;
5559                         $ENV{"SERVER_REALROOT"} = $root0;
5560                         $ENV{"SERVER_PORT"} = $config{'port'};
5561                         $ENV{"WEBMIN_CRON"} = 1;
5562                         $ENV{"DOCUMENT_ROOT"} = $root0;
5563                         $ENV{"DOCUMENT_REALROOT"} = $root0;
5564                         $ENV{"MINISERV_CONFIG"} = $config_file;
5565                         $ENV{"HTTPS"} = "ON" if ($use_ssl);
5566                         $ENV{"MINISERV_PID"} = $miniserv_main_pid;
5567                         $ENV{"SCRIPT_FILENAME"} = $config{'webmincron_wrapper'};
5568                         if ($ENV{"SCRIPT_FILENAME"} =~ /^\Q$root0\E(\/.*)$/) {
5569                                 $ENV{"SCRIPT_NAME"} = $1;
5570                                 }
5571                         $config{'webmincron_wrapper'} =~ /^(.*)\//;
5572                         $ENV{"PWD"} = $1;
5573                         foreach $k (keys %config) {
5574                                 if ($k =~ /^env_(\S+)$/) {
5575                                         $ENV{$1} = $config{$k};
5576                                         }
5577                                 }
5578                         chdir($ENV{"PWD"});
5579                         $SIG{'CHLD'} = 'DEFAULT';
5580                         eval {
5581                                 # Have SOCK closed if the perl exec's something
5582                                 use Fcntl;
5583                                 fcntl(SOCK, F_SETFD, FD_CLOEXEC);
5584                                 };
5585
5586                         # Run the wrapper script by evaling it
5587                         $pkg = "webmincron";
5588                         $0 = $config{'webmincron_wrapper'};
5589                         @ARGV = ( $cron );
5590                         $main_process_id = $$;
5591                         eval "
5592                                 \%pkg::ENV = \%ENV;
5593                                 package $pkg;
5594                                 do \$miniserv::config{'webmincron_wrapper'};
5595                                 die \$@ if (\$@);
5596                                 ";
5597                         if ($@) {
5598                                 print STDERR "Perl cron failure : $@\n";
5599                                 }
5600
5601                         exit(0);
5602                         }
5603                 push(@childpids, $pid);
5604                 }
5605         }
5606 if ($changed) {
5607         # Write out file containing last run times
5608         &write_file($config{'webmincron_last'}, \%webmincron_last);
5609         }
5610 }
5611
5612 # matches_cron(cron-spec, time)
5613 # Checks if some minute or hour matches some cron spec, which can be * or a list
5614 # of numbers.
5615 sub matches_cron
5616 {
5617 my ($spec, $tm) = @_;
5618 if ($spec eq '*') {
5619         return 1;
5620         }
5621 else {
5622         foreach my $s (split(/,/, $spec)) {
5623                 if ($s == $tm ||
5624                     $s =~ /^(\d+)\-(\d+)$/ && $tm >= $1 && $tm <= $2) {
5625                         return 1;
5626                         }
5627                 }
5628         return 0;
5629         }
5630 }
5631
5632 # read_webmin_crons()
5633 # Read all scheduled webmin cron functions and store them in the @webmincrons
5634 # global list
5635 sub read_webmin_crons
5636 {
5637 @webmincrons = ( );
5638 opendir(CRONS, $config{'webmincron_dir'});
5639 print DEBUG "Reading crons from $config{'webmincron_dir'}\n";
5640 foreach my $f (readdir(CRONS)) {
5641         if ($f =~ /^(\d+)\.cron$/) {
5642                 my %cron;
5643                 &read_file("$config{'webmincron_dir'}/$f", \%cron);
5644                 $cron{'id'} = $1;
5645                 my $broken = 0;
5646                 foreach my $n ('module', 'func') {
5647                         if (!$cron{$n}) {
5648                                 print STDERR "Cron $1 missing $n\n";
5649                                 $broken = 1;
5650                                 }
5651                         }
5652                 if (!$cron{'interval'} && !$cron{'mins'} && !$cron{'special'}) {
5653                         print STDERR "Cron $1 missing any time spec\n";
5654                         $broken = 1;
5655                         }
5656                 if ($cron{'special'} eq 'hourly') {
5657                         # Run every hour on the hour
5658                         $cron{'mins'} = 0;
5659                         $cron{'hours'} = '*';
5660                         $cron{'days'} = '*';
5661                         $cron{'months'} = '*';
5662                         $cron{'weekdays'} = '*';
5663                         }
5664                 elsif ($cron{'special'} eq 'daily') {
5665                         # Run every day at midnight
5666                         $cron{'mins'} = 0;
5667                         $cron{'hours'} = '0';
5668                         $cron{'days'} = '*';
5669                         $cron{'months'} = '*';
5670                         $cron{'weekdays'} = '*';
5671                         }
5672                 elsif ($cron{'special'} eq 'monthly') {
5673                         # Run every month on the 1st
5674                         $cron{'mins'} = 0;
5675                         $cron{'hours'} = '0';
5676                         $cron{'days'} = '1';
5677                         $cron{'months'} = '*';
5678                         $cron{'weekdays'} = '*';
5679                         }
5680                 elsif ($cron{'special'} eq 'weekly') {
5681                         # Run every month on the 1st
5682                         $cron{'mins'} = 0;
5683                         $cron{'hours'} = '0';
5684                         $cron{'days'} = '*';
5685                         $cron{'months'} = '*';
5686                         $cron{'weekdays'} = '0';
5687                         }
5688                 elsif ($cron{'special'} eq 'yearly' ||
5689                        $cron{'special'} eq 'annually') {
5690                         # Run every year on 1st january
5691                         $cron{'mins'} = 0;
5692                         $cron{'hours'} = '0';
5693                         $cron{'days'} = '1';
5694                         $cron{'months'} = '1';
5695                         $cron{'weekdays'} = '*';
5696                         }
5697                 elsif ($cron{'special'}) {
5698                         print STDERR "Cron $1 invalid special time $cron{'special'}\n";
5699                         $broken = 1;
5700                         }
5701                 if ($cron{'special'}) {
5702                         delete($cron{'special'});
5703                         }
5704                 if (!$broken) {
5705                         print DEBUG "adding cron id=$cron{'id'} module=$cron{'module'} func=$cron{'func'}\n";
5706                         push(@webmincrons, \%cron);
5707                         }
5708                 }
5709         }
5710 }
5711
5712 # precache_files()
5713 # Read into the Webmin cache all files marked for pre-caching
5714 sub precache_files
5715 {
5716 undef(%main::read_file_cache);
5717 foreach my $g (split(/\s+/, $config{'precache'})) {
5718         next if ($g eq "none");
5719         foreach my $f (glob("$config{'root'}/$g")) {
5720                 my @st = stat($f);
5721                 next if (!@st);
5722                 $main::read_file_cache{$f} = { };
5723                 &read_file($f, $main::read_file_cache{$f});
5724                 $main::read_file_cache_time{$f} = $st[9];
5725                 }
5726         }
5727 }
5728
5729 # Check if some address is valid IPv4, returns 1 if so.
5730 sub check_ipaddress
5731 {
5732 return $_[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ &&
5733         $1 >= 0 && $1 <= 255 &&
5734         $2 >= 0 && $2 <= 255 &&
5735         $3 >= 0 && $3 <= 255 &&
5736         $4 >= 0 && $4 <= 255;
5737 }
5738
5739 # Check if some IPv6 address is properly formatted, and returns 1 if so.
5740 sub check_ip6address
5741 {
5742   my @blocks = split(/:/, $_[0]);
5743   return 0 if (@blocks == 0 || @blocks > 8);
5744   my $ib = $#blocks;
5745   my $where = index($blocks[$ib],"/");
5746   my $m = 0;
5747   if ($where != -1) {
5748     my $b = substr($blocks[$ib],0,$where);
5749     $m = substr($blocks[$ib],$where+1,length($blocks[$ib])-($where+1));
5750     $blocks[$ib]=$b;
5751   }
5752   return 0 if ($m <0 || $m >128);
5753   my $b;
5754   my $empty = 0;
5755   foreach $b (@blocks) {
5756           return 0 if ($b ne "" && $b !~ /^[0-9a-f]{1,4}$/i);
5757           $empty++ if ($b eq "");
5758           }
5759   return 0 if ($empty > 1 && !($_[0] =~ /^::/ && $empty == 2));
5760   return 1;
5761 }
5762
5763 # network_to_address(binary)
5764 # Given a network address in binary IPv4 or v4 format, return the string form
5765 sub network_to_address
5766 {
5767 local ($addr) = @_;
5768 if (length($addr) == 4 || !$use_ipv6) {
5769         return inet_ntoa($addr);
5770         }
5771 else {
5772         return Socket6::inet_ntop(Socket6::AF_INET6(), $addr);
5773         }
5774 }
5775
5776 # redirect_stderr_to_log()
5777 # Re-direct STDERR to error log file
5778 sub redirect_stderr_to_log
5779 {
5780 if ($config{'errorlog'} ne '-') {
5781         open(STDERR, ">>$config{'errorlog'}") ||
5782                 die "failed to open $config{'errorlog'} : $!";
5783         if ($config{'logperms'}) {
5784                 chmod(oct($config{'logperms'}), $config{'errorlog'});
5785                 }
5786         }
5787 select(STDERR); $| = 1; select(STDOUT);
5788 }
5789
5790 # should_gzip_file(filename)
5791 # Returns 1 if some path should be gzipped
5792 sub should_gzip_file
5793 {
5794 my ($path) = @_;
5795 return $path !~ /\.(gif|png|jpg|jpeg|tif|tiff)$/i;
5796 }
5797
5798 # get_expires_time(path)
5799 # Given a URL path, return the client-side expiry time in seconds
5800 sub get_expires_time
5801 {
5802 my ($path) = @_;
5803 foreach my $pe (@expires_paths) {
5804         if ($path =~ /$pe->[0]/i) {
5805                 return $pe->[1];
5806                 }
5807         }
5808 return $config{'expires'};
5809 }
5810