CGIservlet.pl

   1 #! /usr/bin/perl
   2 #
   3 # Put the full path to perl on the first line, run the program with
   4 # `perl CGIservlet`, or put a symbolic link to perl in
   5 # the startup directory if you need a special version of perl.
   6 #
   7 if(grep(/\-\-help/i, @ARGV))
   8 {
   9     print << 'ENDOFHELPTEXT';
  10 # CGIservlet:
  11 #         A HTTPd "connector" for running CGI scripts on unix systems as WWW
  12 #         accessible Web sites. The servlet starts a true HTTP daemon that channels
  13 #         HTTP requests to forked daughter processes. CGIservlet.pl is NOT a
  14 #         full fledged server. Moreover, this servlet is definitely NOT intended
  15 #         as a replacement of a real server (e.g., Apache). It's design goal was
  16 #         SIMPLICITY, and not mileage.
  17 #
  18 #         Note that a HTTP server can be accessed on your local machine WITHOUT
  19 #         internet access (but WITH a DNS?):
  20 #         use "http://localhost[:port]/[path]" or "http://127.0.0.1[:port]/[path]"
  21 #         as the URL. It is also easy to restrict access to the servlet to localhost
  22 #         users (i.e., the computer running the servlet).
  23 #
  24 #         Suggested uses:
  25 #         - A testbed for CGI-scripts and document-trees outside the primary server.
  26 #           When developing new scripts and services, you don't want to mess up your
  27 #           current Web-site. CGIservlet is an easy way to start a temporary (private)
  28 #           server. CGIservlet allows to test separate HTTP server components, e.g.,
  29 #           user authentication, in isolation.
  30 #
  31 #         - A special purpose temporary server (WWW everywhere/anytime).
  32 #           We run identification and other experiments over the inter-/intra-net using
  33 #           CGI-scripts. This means a lot of development and changes and only little
  34 #           actual run-time. The people doing this do not want "scripting" access to our
  35 #           departmental server with all its restrictions and security. So we need a
  36 #           small, lightweigth, easy-to-configure server that can be run by each
  37 #           investigator on her own account (and risk).
  38 #
  39 #         - Interactive WWW presentations.
  40 #           Not everyone is content with the features of "standard" office presentation
  41 #           software. HTML and its associated browsers are an alternative (especially
  42 #           under Linux). However, you need a server to realize the full interactive
  43 #           nature of the WWW. CGIservlet with the necessary scripts can be run from
  44 #           a floppie (a Web server in 100 kB). The CGIservlet can actually run a
  45 #           (small) web site from RAM, without disk access (if you DO NOT use the
  46 #           2>pid.log redirection on startup).
  47 #           With the "localhost" or "127.0.0.1" id in your browser you can use the
  48 #           servlet standalone.
  49 #
  50 #         When the servlet is started with the -r option, only requests from "localhost"
  51 #         or "127.0.0.1" are accepted (default) or from addresses indicated after the
  52 #         -r switch.
  53 #
  54 #         Running demo's and more information can be found at
  55 #         http://www.fon.hum.uva.nl/rob/OSS/OSS.html
  56 #
  57 #
  58 ############################################################################
  59 #
  60 # Changes (document ALL changes with date, name and email here):
  61 #
  62 # 28 Mar 2013 - Version 1.4.
  63 # 18 Jun 2012 - Added --env, %UserEnv user defined ENV variables. Freeze %ENV.
  64 # 06 Jun 2012 - Added HTTP Cookie string to an Environment variable: COOKIE_JAR
  65 # 29 May 2012 - Added .log -> / to @RegAliasTranslation, blocks attempts to read
  66 #               log files.
  67 # 22 May 2012 - Blocked "hidden" files and directories starting with "." in
  68 #               default @RegAliasTranslation. Removed obsolete CVS reference.
  69 # 21 May 2012 - Inserted the -m[emory] switch for loading and serving from RAM.
  70 #               The option was mentioned in the manual, but the cli switch was
  71 #               never added.
  72 # 22 Jul 2003 - Plain output using binary print io. `cat ...`
  73 # 22 Jul 2003 - Added 'use CGI::Carp qw(fatalsToBrowser);' line
  74 #               for debugging. Standard this is commented out
  75 #               for security reasons (suggested by Jochen_Hayek@ACM.org).
  76 # 22 Jul 2003 - Added error checking to doarg (suggested by Jochen_Hayek@ACM.org)
  77 # 22 Jul 2003 - Removed SERVER_PORT from HTTP_HOST (Bug found by Jochen_Hayek@ACM.org)
  78 # 22 Jul 2003 - Updated documentation. Added CGIservlet directory
  79 #               to the search path of CGIservletSETUP.pl
  80 # 20 May 2003 - Made sure recycled (double) pid's do not mess up the
  81 #               @brood list and added a --help switch.
  82 # 20 May 2003 - Added a maximum running time for child processes
  83 #               with command line switch -xterm.
  84 # 15 Jan 2002 - Version 1.3
  85 # 19 Oct 2001 - Included browsing of directories and a new -s
  86 #               security switch. With security toggled of
  87 #               directories can be browsed and all mime-types
  88 #               are served, either as 'text/plain' or as
  89 #               'application/octed-stream'.
  90 # 18 May 2001 - Added some HTTP HTTP lines.
  91 # 13 Jun 2000 - Included the possibility to add POST request
  92 #               to GET query-strings (and change the request
  93 #               method). The -l ($Maxlength) maximum length
  94 #               option now covers POST requests too.
  95 #  8 Dec 1999 - Included hooks for compression when running from RAM.
  96 #  2 Dec 1999 - Autoflush enabled.
  97 #  2 Dec 1999 - Allow running a Web Site from RAM.
  98 #  2 Dec 1999 - Changed the behavior of CGIservletSETUP. CGIservlet
  99 #               will eval ALL setup files, the one in the CGIscriptor
 100 #               subdirectory (if any) AND the one in the current
 101 #               directory. (also added a close(SETUP) command)
 102 # 26 Nov 1999 - Added some minimal security for 'automatic', out of
 103 #                       the box installation.
 104 # 26 Nov 1999 - Made the text/osshell mime-type functional (i.e.,
 105 #                       without any scripts, implement a dynamic web server)
 106 #               Linited to '.cgi' extension.
 107 # 26 Nov 1999 - Added aliasing of URL paths, both one-to-one lookups
 108 #                and full regular expression, i.e., $Path =~ s/.../.../g
 109 #                replace commands
 110 # 28 Sep 1999 - Made all client supplied HTTP parameter names lowercase
 111 #                       to handle inconsistencies in case use.
 112 # 29 Jul 1999 - Allowed for a SETUP configuration file 'CGIservletSETUP.pl'.
 113 #               Use $beginarg from the 'CGIscriptor/' directory if it exists.
 114 #               (R.J.J.H.vanSon@gmail.com)
 115 #
 116 #
 117 ############################################################################
 118 #
 119 # Known bugs
 120 #
 121 # 23 Mar 2000 - An odd server side network error is reported by Netscape
 122 #               when a Post is initiated from a Javascript Submit of a
 123 #               <FORM>. This was found on Red Hat 6.1 Linux with perl 5.00503,
 124 #               5.00503 and 5.6.0. But not on IRIX or Red Hat 5.0, 7.x.
 125 #
 126 ############################################################################
 127 #
 128 #
 129 # Inner workings:
 130 #         Whenever an HTTP request is received, the specified CGI script is
 131 #         started inside a child process as if it was inside a real server (e.g.,
 132 #         Apache). The evironment variables are set more or less as in Apache.
 133 #         Note that CGIservlet only uses a SINGLE script for ALL requests.
 134 #         No attemps for security are made, it is the script's responsibility to
 135 #         check access rights and the validity of the request.
 136 #         When no scripts are given, CGIservlet runs as a bare bone WWW server
 137 #         configurable to execute scripts (the default setting is as a
 138 #         STATIC server).
 139 #
 140 # Author and copyright (c) :
 141 #         Rob van Son
 142 #         email:
 143 #         R.J.J.H.vanSon@gmail.com
 144 #         r.v.son@nki.nl
 145 #         NKI/AVL Amsterdam
 146 #
 147 #         copying freely from the mhttpd server by Jerry LeVan (levan@eagle.eku.edu)
 148 # Date:   July 22, 2012
 149 # Version:1.4
 150 # Env:    Perl 5.002 and later
 151 #
 152 #
 153 ################################################################################
 154 #                                                                              #
 155 #          LICENSE                                                             #
 156 #                                                                              #
 157 #          This program is free software; you can redistribute it and/or       #
 158 #          modify it under the terms of the GNU General Public License         #
 159 #          as published by the Free Software Foundation; either version 2      #
 160 #          of the License, or (at your option) any later version.              #
 161 #                                                                              #
 162 #          This program is distributed in the hope that it will be useful,     #
 163 #          but WITHOUT ANY WARRANTY; without even the implied warranty of      #
 164 #          MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       #
 165 #          GNU General Public License for more details.                        #
 166 #                                                                              #
 167 #          You should have received a copy of the GNU General Public License   #
 168 #          along with this program; if not, write to the Free Software         #
 169 #          Foundation, Inc., 59 Temple Place - Suite 330,                      #
 170 #          Boston, MA  02111-1307, USA.                                        #
 171 #                                                                              #
 172 ################################################################################
 173 #
 174 # Note:   CGIservlet.pl was directly inspired by Jerry LeVan's
 175 #         (levan@eagle.eku.edu) simple mhttpd server which again was
 176 #         inspired by work of others. CGIservlet is used as a bare bones
 177 #         socket server for a single CGI script at a time.
 178 #
 179 # Use:    CGIservlet.pl -<switch> <argument> 2>pid.log &     (sh/bash)
 180 #         CGIservlet.pl -<switch> <argument> >&pid.log &     (csh)
 181 #
 182 #         The servlet prints out pid and port number on STDERR. It is
 183 #         adviced to store these in a separate file (this will become the
 184 #         error log).
 185 #         NOTE: When running CGIservlet from a Memmory Image (i.e. RAM),
 186 #         do NOT redirect the error output to a file, but use something
 187 #         like MAILTO or /dev/null!
 188 #
 189 # Stop:   sh pid.log                    (kills the server process)
 190 #
 191 #         The first line in the file that receives STDERR output is a command
 192 #         to stop CGIservlet.
 193 #
 194 #         examples:
 195 #         CGIservlet.pl -p 2345 -d /cgi-bin/CGIscriptor.pl -t /WWW 2>pid.log &
 196 #         CGIservlet.pl -p 8080 -b 'require "CGIscriptor.pl";' -t $PWD -e \
 197 #         'Handle_Request();' 2>pid.log &
 198 #
 199 #         The following example settings implement a static WWW server using 'cat'
 200 #         (and prohibiting Queries):
 201 #         -p 8008
 202 #         -t `pwd`
 203 #         -b ''
 204 #         -e
 205 # '$ENV{QUERY_STRING}="";$ENV{PATH_INFO}=~/\.([\w]+)$/; "Content-type: ".$mimeType{uc($1)}."\n\n";'
 206 #         -d 'cat -u -s'
 207 #         -w '/index.html'
 208 #         -c 32
 209 #         -l 512
 210 #
 211 #         This is identical to the (static) behaviour of CGIservlet when
 212 #         -e '' -d '' -x '' is used.
 213 #         The CGIservlet command should be run from the intended server-root directory.
 214 #
 215 #         Another setting will use a package 'CGIscriptor.pl' with a function
 216 #         'HandleRequest()' to implement an interactive WWW server with inline
 217 #         Perl scripting:
 218 #         -p 8080
 219 #         -t `pwd`
 220 #         -b 'require "CGIscriptor.pl";'
 221 #         -e 'HandleRequest();'
 222 #         -d ''
 223 #         -w '/index.html'
 224 #         -c 32
 225 #         -l 32767
 226 #
 227 #         Look below or in the CGIservletSETUP.pl file for the current default
 228 #         settings.
 229 #
 230 #
 231 # ###############################################################################
 232 #
 233 #         There are many switches to tailor the workings of CGIservlet.pl.
 234 #         Some are fairly esoteric and you should only look for them if you
 235 #         need something special urgently. When building a Web site,
 236 #         the specific options you need will "suggest" themselves (e.g., port
 237 #         number, script, or server-root directory). Most default settings
 238 #         should work fine.
 239 #
 240 #         You can add your own configuration in a file called
 241 #         'CGIservletSETUP.pl'. This file will be executed ("eval"-ed)
 242 #         after the default setup, but before the command line options take
 243 #         effect. CGIservlet looks for the SETUP file in the startup directory
 244 #         and in the CGIscriptor subdirectory.
 245 #         (Note that the $beginarg variable is evaluated AFTER the setup file).
 246 #
 247 #         In any case, it is best to change the default settings instead of
 248 #         using the option switches. All defaults are put in a single block.
 249 #
 250 #         switches and arguments:
 251 #         Realy important
 252 #         -p[ort] port number
 253 #          For example -p 2345
 254 #          Obviously the port CGIservlet listenes to. Suggested Default: -p 8008
 255 #
 256 #         -a[lias] Alias1 RealURL1 ...
 257 #          For example -a '/Stimulus.aifc' '/catAIFC.xmr'
 258 #          Replaces the given Alias URL path by its real URL path. Accepts full
 259 #          regular expressions too (identified by NON-URL characters).
 260 #          That is, on each request it performs (in order):
 261 #          if($AliasTranslation{$Path})
 262 #          {
 263 #              $Path = $AliasTranslation{$Path};
 264 #          }
 265 #          elsif(@RegAliasTranslation)
 266 #          {
 267 #             my $i;
 268 #             for($i=0; $i<scalar(@RegAliasTranslation); ++$i)
 269 #             {
 270 #                 my $Alias   = $RegAliasTranslation[$i];
 271 #                 my $RealURL = $RegURLTranslation[$i];
 272 #                 last if ($Path =~ s#$Alias#$RealURL#g);
 273 #             };
 274 #          };
 275 #          The effects can be quite drastic, so be
 276 #          carefull. Note also, that entering many Regular Expression
 277 #          aliases could slow down your servlet. Checking stops after
 278 #          the first match.
 279 #          Full regular expression alias translations are done in the
 280 #          order given! They are recognized as Aliases containing
 281 #          regexp's (i.e., non-URL) operator characters like '^' and
 282 #          '$'.
 283 #          Note: The command line is NOT a good place for entering
 284 #          Aliases, change the code below or add aliases to
 285 #          CGIservletSETUP.pl.
 286 #
 287 #         --help
 288 #          Prints the manual
 289 #
 290 #         Script related
 291 #         -b[egin] perl commands
 292 #          For example -b 'require "CGIscriptor.pl";' or
 293 #          'require "/WWW/cgi-bin/XMLelement.pl";'
 294 #          Perl commands evaluated at server startup
 295 #
 296 #         -d[o] perl script file
 297 #          For example -d '/WWW/cgi-bin/CGIscriptor.pl'
 298 #          The actual CGI-script started as a perl {do "scriptfile"} command.
 299 #          The PATH_INFO and the QUERY are pushed on @ARGV.
 300 #
 301 #         -x shell command
 302 #         -qx shell command
 303 #         -exec shell command
 304 #          OS shell script or command, e.g., -x 'CGIscriptor.pl' or
 305 #          -x '/WWW/cgi-bin/my-script'
 306 #          The actual CGI-script started as `my-script \'$Path\' \'$QueryString\'`.
 307 #          -qx and -exec[ute] are aliases of -x. For security reasons, Paths or
 308 #          queries containing '-quotes are rejected.
 309 #
 310 #         -e[val] perl commands
 311 #          For example -e 'Handle_Request();'
 312 #          The argument is evaluated as perl code. The actual CGI-script
 313 #          can be loaded once with -b 'require module.pm' and you only have to
 314 #          call the central function(s).
 315 #
 316 #         WWW-tree related
 317 #         -t[extroot] path
 318 #          For example -t "$PWD" or -t "/WWW/documents"
 319 #          The root of the server hierachy. Defaults to the working directory
 320 #          at startup time (`pwd`)
 321 #
 322 #         -w[elcome] filepath
 323 #          For example -w "/index.html"   (default)
 324 #          The default welcome page used when no path is entered. Note that
 325 #          this path can point to anything (or nothing real at all).
 326 #
 327 #         Security related
 328 #         The following arguments supply some rudimentary security. It is the
 329 #         responsibility of the script to ensure that the requests are indeed
 330 #         "legal".
 331 #
 332 #         -c[hildren] maximum child processes
 333 #          For example -c 32
 334 #          The maximum number of subprocesses started. If there are more requests,
 335 #          the oldest requests are "killed". This should take care of "zombie"
 336 #          processes and server overloading. Note that new requests will be
 337 #          serviced irrespective of the success of killing it's older siblings.
 338 #
 339 #         -xtime maximum running time of a child
 340 #          For example -xtime 36000
 341 #          The maximum time a child may run in seconds. After a new request has
 342 #          been servised, all children that have run for longer than this time
 343 #          will be killed. This stops runaway processes, often connected to
 344 #          web-crawlers.
 345 #
 346 #         -l[ength] maximum length of HTTP request in bytes
 347 #          For example -l 32768
 348 #          This prevents overloading the server with enormous queries. Reading of
 349 #          requests simply stops when this limit is reached. This DOES affect
 350 #          POST requests.  If the combined length of the COMPLETE HTTP request,
 351 #          including headers, exceeds this limit, the whole request is dropped.
 352 #
 353 #         -r[estrict] [Remote-address [Remote-host]]
 354 #          For example -r 127.0.0.1          (default of -r)
 355 #          A space separated list of client IP addresses and/or domain names that
 356 #          should be serviced. Default, i.e., '-r' without any addresses or domain
 357 #          names, is the localhost IP address '127.0.0.1'.
 358 #          When using CGIservlet for local purposes only (e.g., development or a
 359 #          presentation), it would be unsafe to allow others to access the servlet.
 360 #          If -r is used (or the corresponding @RemoteAddr or @RemoteHost lists are
 361 #          filled in the code below), all requests from clients whose Remote-address
 362 #          or Remote-host do not match the indicated addresses will be rejected.
 363 #          Partial addresses and domain names are allowed. Matching is done according
 364 #          to Remote-addr =~ /^\Q$pattern\E/ (front to back) and
 365 #          Remote-host =~ /\Q$pattern\E$/ (back to front)
 366 #
 367 #          --env name=value,name=value
 368 #          Watch double dash. Define $ENV{name}=value for every pair. These are
 369 #          internally stored in %UserEnv, eg, $UserEnv{name}=value; This is set anew
 370 #          in the Child with every request. That is, Changes in %ENV are not stored.
 371 #
 372 #         -s[ecure]
 373 #          No arguments.
 374 #          A toggle switch that blocks all access to files with undefined
 375 #          mime-types (or to serve ascii files as "text/plain"), and blocking directory
 376 #          browsing. Defaults to blocking what is not explicitely allowed.
 377 #
 378 #         -m[emory]
 379 #          No arguments.
 380 #          Reads complete Web site into memory and runs from this image.
 381 #          Set $UseRAMimage = 1; to activate memory-only running.
 382 #          Under certain circumstance, this can improve security.
 383 #          Note, however, that running osshellscripts from this image
 384 #          makes any "security" related claims very shaky.
 385 #
 386 #         Speedup
 387 #         -n[oname]
 388 #          No arguments.
 389 #          Retrieving the domain name of the Client (i.e., Remote-host) is a
 390 #          very slow process and normally useless. To skip it, enter this
 391 #          option. Note that you cannot use '-r Remote-host' anymore after
 392 #          you enter -n, only IP addresses will work.
 393 #
 394 #     Configuration with the CGIservletSETUP.pl file
 395 #
 396 #     You can add your own configuration in a file
 397 #     called 'CGIservletSETUP.pl'. This file will be executed ("eval"-ed)
 398 #     after the default setup, but before the command line options take
 399 #     effect. CGIservlet looks for the SETUP file in the startup directory
 400 #     and in the CGIservlet and CGIscriptor subdirectories.
 401 #     (Note that the $beginarg variable is evaluated even later).
 402 #
 403 #         Changing POST to GET requests
 404 #
 405 #         CGIservlet normally only handles requests with the GET method. Processing
 406 #         the input from POST requests is left to the reading application. POST
 407 #         requests add some extra complexity to processing requests. Sometimes,
 408 #         the reading application doesn't handle POST requests. CGIservlet
 409 #         already has to manage the HTTP request. Therefore, it can easily
 410 #         handle the POST request. If the variable $POSTtoGET is set to any
 411 #         non-false value, the content of whole POST request is added to the
 412 #         QUERY_STRING environment variable (preceeded by a '&' if necessary).
 413 #         The content-length is set to 0. If $POSTtoGET equals 'GET', the method
 414 #         will also be changed to 'GET'.
 415
 416 #          remarks:
 417 #          All of the arguments of -d, -e, and -x are processed sequentially
 418 #          in this order. This might not be what you want so you should be
 419 #          carefull when using multiple executable arguments.
 420 #          If none of the executable arguments is DEFINED (i.e., they are entered
 421 #          as -d '' -e '' -x ''), each request is treated as a simple
 422 #          text-retrieval. THIS CAN BE A SECURITY RISK!
 423 #
 424 #          The wiring of an interactive web-server, which also calls shell
 425 #          scripts with the extension '.cgi', is in place. You can
 426 #          "activate" it by changing the "my $ExecuteOSshell = 0;" line to
 427 #          "my $ExecuteOSshell = 1;".
 428 #          If you have trouble doing this, it might be a good idea
 429 #          to reconsider using a dynamic web server. Executing shell
 430 #          scripts inside a web server is a rather dangerous practise.
 431 #
 432 #          CGIservlet can run its "standard" web server from memory.
 433 #          At startup, all files are read into a hash table. Upon
 434 #          request, the contents of the file are placed in the
 435 #          environment variable: CGI_FILE_CONTENTS.
 436 #          No further disk access is necessary. This means that:
 437 #          1 CGIservlet can run a WWW site from a removable disk,
 438 #            e.g., a floppy
 439 #          2 The web servlet can run without any read or write privilege.
 440 #          3 The integrity of the Web-site contents can be secured at the
 441 #            level you want
 442 #
 443 #          To compres the memory (RAM) immage, you should hook the
 444 #          compression function to
 445 #          $CompressRAMimage = sub { return shift;};
 446 #          and the decompression function to
 447 #          $DecompressRAMimage = sub { return shift;};
 448 #
 449 #
 450 ENDOFHELPTEXT
 451     exit;
 452 };
 453 ###################################################################################
 454 #
 455 require 5.002;
 456 use strict;  # Should realy be used!
 457 use Socket;
 458 use Carp;    # could come in handy (can be missed, I think)
 459
 460 # For debugging: uncommenting the use-line below will send
 461 # nicely formanted output to the client. However, it is
 462 # generally not a good idea to enable clients to test your
 463 # scripts and look for holes (SECURITY).
 464 # use CGI::Carp qw(fatalsToBrowser);
 465
 466 $| = 1;      # Autoflush (i'm not sure whether this is usefull)
 467
 468 my $version = "1.301";
 469 my $program = "CGIservlet.pl";
 470
 471 ##################################################################
 472 #                                                                #
 473 #   print some information to STDERR, e.g., the process number   #
 474 #                                                                #
 475 ##################################################################
 476 sub logmsg { print STDERR "kill -KILL $$;exit;\n",   # Stop CGIservlet
 477 "$0 $$: @_ at ", scalar localtime, "\n" }
 478
 479 ############################################################
 480 #                                                          #
 481 #   Parse arguments (you can define DEFAULT VALUES here)   #
 482 #                                                          #
 483 ############################################################
 484
 485 my $port      = 8008;        # The port number
 486
 487 # Add POST requests to the QUERY_STRING, change method to
 488 # GET if the value is 'GET'
 489 my $POSTtoGET = 0;                      # Add POST requests to the query string
 490
 491 # (Fast) direct translation of full URL paths
 492 my %AliasTranslation = ();   # Alias => RealURL pairs (ONLY paths)
 493 # Regular expression alias translation, in order of application
 494 # (this can be quite slow)
 495 my @RegAliasTranslation = ('^(\..*|.*/\..*)$','\.htm$', '^.*\.log$'); # Full regular expression alias/url pairs: URL
 496 my @RegURLTranslation = ('/','.html', '/');   # Full regular expression alias/url pairs: PATH
 497
 498 my $textroot  = $ENV{'PWD'} || `pwd`; # current working directory
 499 chomp($textroot);            # Remove nasty newline, if present
 500 my $doarg     = '';          # do "filename",
 501
 502 my $beginarg  = '';          # eval($Argument) at the start of the program
 503 my $evalarg   = '';          # eval($Argument) for each request
 504 my $execarg   = '';          # execute `command \'$textroot$Path\' \'$QueryString\'`
 505
 506 my $welcome   = '/index.html';  # Default path
 507
 508 #  Rudimentary security, overflow detection
 509 my $MaxBrood  = 32;          # Maximum number of running children
 510 my $MaxTime  = 36000;        # Maximum time a child may run in seconds
 511 my $MaxLength = 2**15;       # Maximum Request Length
 512 my $Secure = 1;                 # Block browsing directories and text files or not
 513 my %UserEnv = ();
 514
 515 # If one of the following lists contains any client addresses or names, all others are
 516 # blocked (be carefull, your site will be inaccessible if you misspell them).
 517 my @RemoteHost = ();         # Accepted Hosts, suggest: localhost
 518 my @RemoteAddr = ();         # Accepted IP addresses, suggest: @RemoteAddr=('127.0.0.1')
 519 my $DefaultRemoteAddr = '127.0.0.1';  # default, use localhost IP address
 520 my $NONAME = 0;              # if 1, do NOT ask for REMOTE_HOST (faster)
 521
 522 # Initialization ready
 523 my %FrozenEnv = %ENV;                   # Freeze %ENV
 524
 525 # Store the whole Web Site in a hash table and use this RAM memory image (if non-zero)
 526 my $UseRAMimage = 0;
 527 # Empty function handlers for data compression
 528 # In general, these must be redefined in the $beginarg
 529 my $CompressRAMimage = sub { return shift;};
 530 my $DecompressRAMimage = sub { return shift;};
 531
 532 # Execute shell CGI scripts when no -d, -e, or -x are supplied
 533 my $ExecuteOSshell = 0;      # Do you REALY want this? It is dangerous
 534
 535 #################################################################
 536 #                                                               #
 537 #   Configure CGIservlet with a setup file (overides the        #
 538 #   default settings, but not the command line options).        #
 539 #   Note that, if it exists, the setup file in the CGIscriptor  #
 540 #   subdirectory is processed EVEN if there is a SETUP file     #
 541 #   in the current directory.                                   #
 542 #                                                               #
 543 #################################################################
 544 # There exists a CGIservlet subdirectory and it contains
 545 # a CGIservletSETUP.pl file
 546 if((-e './CGIservlet/CGIservletSETUP.pl') &&
 547    open(SETUP, '<./CGIservlet/CGIservletSETUP.pl'))
 548 {
 549     # Get the setup code
 550     my $SetupCode = join("", <SETUP>);
 551     # 'Eval' is used to ensure that the values are entered in the current
 552     # package (contrary to what 'do' and 'require' do).
 553     (eval $SetupCode) || die "$! $@\n";
 554     close(SETUP);
 555 };
 556 # There exists a CGIscriptor subdirectory and it contains
 557 # a CGIservletSETUP.pl file
 558 if((-e './CGIscriptor/CGIservletSETUP.pl') &&
 559    open(SETUP, '<./CGIscriptor/CGIservletSETUP.pl'))
 560 {
 561     # Get the setup code
 562     my $SetupCode = join("", <SETUP>);
 563     # 'Eval' is used to ensure that the values are entered in the current
 564     # package (contrary to what 'do' and 'require' do).
 565     (eval $SetupCode) || die "$! $@\n";
 566     close(SETUP);
 567 };
 568 # There is a CGIservletSETUP.pl file in the current directory
 569 if((-e './CGIservletSETUP.pl') &&
 570    open(SETUP, '<./CGIservletSETUP.pl'))
 571 {
 572     # Get the setup code
 573     my $SetupCode = join("", <SETUP>);
 574     # 'Eval' is used to ensure that the values are entered in the current
 575     # package (contrary to what 'do' and 'require' do).
 576     (eval $SetupCode) || die "-e $SetupCode: $! $@\n";
 577     close(SETUP);
 578 };
 579
 580 ######################################
 581 #                                    #
 582 #   process arguments and defaults   #
 583 #                                    #
 584 ######################################
 585
 586 while ($_ = shift(@ARGV))
 587 {
 588     # With switches
 589     if(/\-p/is)               # Port
 590     {
 591         $port = shift(@ARGV);
 592     }
 593     elsif(/\-d/is)            # Do
 594     {
 595         $doarg = shift(@ARGV);
 596     }
 597     elsif(/\-(x|qx|exec)/is)  # Execute
 598     {
 599         $execarg = shift(@ARGV);
 600     }
 601     elsif(/\-b/is)            # Begin
 602     {
 603         $beginarg = shift(@ARGV);
 604     }
 605     elsif(/^\-e/is)            # Evaluate
 606     {
 607         $evalarg = shift(@ARGV);
 608     }
 609     elsif(/\-t/is)            # Textroot
 610     {
 611         $textroot = shift(@ARGV);
 612     }
 613     elsif(/\-w/is)            # Default welcome page
 614     {
 615         $welcome = shift(@ARGV);
 616     }
 617     elsif(/\-c/is)            # Maximum Children
 618     {
 619         $MaxBrood = shift(@ARGV) || $MaxBrood;
 620     }
 621     elsif(/\-xtime/is)        # Maximum running time
 622     {
 623         $MaxTime = shift(@ARGV) || $MaxTime;
 624     }
 625     elsif(/\-l/is)            # Maximum Length
 626     {
 627         $MaxLength = shift(@ARGV) || $MaxLength;
 628     }
 629     elsif(/\-m/is)            # Run from RAM
 630     {
 631         $UseRAMimage = 1;
 632     }
 633     elsif(/\-a/is)            # Aliases
 634     {
 635         while(@ARGV && $ARGV[0] !~ /^\-/) # while not a parameter
 636         {
 637             my $Alias = shift(@ARGV);
 638             my $RealURL = $ARGV[0] !~ /^\-/ ? shift(@ARGV) : "";
 639             next unless $Alias && $RealURL;
 640             # Store the alias
 641             # Simple straight translations
 642             unless($Alias =~ m/[\$\Q^*&@!\?(){}[];:\E]/)
 643             {
 644                 $AliasTranslation{$Alias} = $RealURL;
 645             }
 646             else  # Full regular expressions
 647             {
 648                 push(@RegAliasTranslation, $Alias);
 649                 push(@RegURLTranslation, $RealURL);
 650             };
 651
 652         };
 653     }
 654     elsif(/\-r/is)            # Remote host or address
 655     {
 656         while(@ARGV && $ARGV[0] !~ /^\-/) # while not a parameter
 657         {
 658             my $Remote = shift(@ARGV);
 659             if($Remote =~ /[\d\.]+/) # A host IP address
 660             {
 661                 push(@RemoteAddr, $Remote);
 662             }
 663             else                     # A host domain name, less secure
 664             {
 665                 push(@RemoteHost, $Remote);
 666             };
 667         };
 668         #
 669         # Use the default Remote Host (Client) IP address (e.g., localhost)
 670         # if no addresses or domain names are entered.
 671         push(@RemoteAddr, $DefaultRemoteAddr) unless @RemoteAddr || @RemoteHost;
 672     }
 673     elsif(/^\-\-env/is)            # Environment variables
 674     {
 675        while(@ARGV && $ARGV[0] !~ /^\-/) # while not a parameter
 676         {
 677                         my $envlist = shift(@ARGV);
 678                         foreach my $envstring (split(',', $envlist))
 679                         {
 680                                 my ($name, $value) = split('=', $envstring);
 681                                 next unless $name;
 682                                 # Store the Environment variable
 683                                 $UserEnv{$name} = $value;
 684                         };
 685         };
 686     }
 687     elsif(/\-s/is)            # Secure or not
 688     {
 689                 $Secure = !$Secure;     # Toggle blocking directory browsing and ASCII file access
 690     }
 691     elsif(/\-n/is)            # Do NOT extract Remote host
 692     {
 693                 $NONAME = 1;
 694     }
 695     else        # perform unreliable magick without switches
 696     {
 697         if(/^[0-9]+$/ && $_ > 1024)     # A (large) number must be a port
 698         {
 699             $port = $_;
 700         }
 701         elsif(-T && /\.pl$/)    # Text file with extension .pl is a Perl file
 702         {
 703             $doarg = $_;
 704         }
 705         elsif(-T && /\.pm$/)    # Text file with extension .pm is a Perl module file
 706         {
 707             $beginarg = $_;
 708         }
 709         elsif(-x)       # Executables can be executed
 710         {
 711             $execarg = $_;
 712         }
 713         elsif(-d)       # A directory can only be the root
 714         {
 715             $textroot = $_;
 716         }
 717         elsif(-T && /^\// && /\.html$/) # An html file path is the default path
 718         {
 719             $welcome = $_;
 720         }
 721         elsif(-T)       # A text file is something to do
 722         {
 723             $doarg = $_;
 724         }
 725         elsif(/[\s\{\`\[\@\%]/)         # I give up, just try it
 726         {
 727             $evalarg = shift(@ARGV);
 728         };
 729     };
 730 };
 731
 732 ################################################
 733 #                                              #
 734 #   All argument values are known.             #
 735 #   Initialize environment variables.          #
 736 #   (should be accessible to eval($beginarg))  #
 737 #                                              #
 738 ################################################
 739 #
 740 # Initialize %ENV
 741 $ENV{'SERVER_SOFTWARE'} = "$program $version";
 742 $ENV{'GATEWAY_INTERFACE'} = "CGI/1.1";
 743 $ENV{'SERVER_PORT'} = "$port";
 744 $ENV{'CGI_HOME'} = $textroot;
 745 $ENV{'SERVER_ROOT'} = $textroot;                # Server Root Directory
 746 $ENV{'DOCUMENT_ROOT'} = $textroot;              # Server Root Directory
 747 $ENV{'SCRIPT_NAME'} = $doarg.$execarg.$evalarg;  # Combine executable arguments
 748
 749 $FrozenEnv{'SERVER_SOFTWARE'} = $ENV{'SERVER_SOFTWARE'};
 750 $FrozenEnv{'GATEWAY_INTERFACE'} = $ENV{'GATEWAY_INTERFACE'};
 751 $FrozenEnv{'SERVER_PORT'} = $ENV{'SERVER_PORT'};
 752 $FrozenEnv{'CGI_HOME'} = $ENV{'CGI_HOME'};
 753 $FrozenEnv{'SERVER_ROOT'} = $ENV{'SERVER_ROOT'};                # Server Root Directory
 754 $FrozenEnv{'DOCUMENT_ROOT'} = $ENV{'DOCUMENT_ROOT'};              # Server Root Directory
 755 $FrozenEnv{'SCRIPT_NAME'} = $ENV{'SCRIPT_NAME'};  # Combine executable arguments
 756
 757 ################################################
 758 #                                              #
 759 #   The initial argument should be evaluated   #
 760 #                                              #
 761 ################################################
 762
 763 eval($beginarg) if $beginarg;
 764
 765 ################################################
 766 #                                              #
 767 #   The initial argument has been evaluated    #
 768 #                                              #
 769 ################################################
 770 #
 771 # Socket related code
 772 my $proto = getprotobyname('tcp');
 773 $port = $1 if $port =~ /(\d+)/; # untaint port number
 774
 775 socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
 776 setsockopt(Server, &SOL_SOCKET, &SO_REUSEADDR,
 777 pack("l", 1))                               || die "setsockopt: $!";
 778 bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
 779 listen(Server,SOMAXCONN)                            || die "listen: $!";
 780
 781 #
 782 # Report start of server
 783 logmsg "server started on port $port";
 784
 785 # Set up SIG vector (every signal will kill the process that receives it)
 786 $SIG{CHLD} = 'IGNORE';
 787 $SIG{'KILL'} = "SigHandler";
 788 $SIG{'TERM'} = "SigHandler";
 789 $SIG{'QUIT'} = "SigHandler";
 790 $SIG{'HUP'}  = "SigHandler";
 791
 792 # Define text mime types served if no scripts are defined
 793 # Note that the "text/osshell" mime-type is executed by CGIservlet ITSELF!
 794 # You should remove it if you don't want that!
 795 my %mimeType = (
 796 'HTML'=> "text/html",
 797 'TXT' => "text/plain",
 798 'PL'  => "text/plain",    # This is incorrect, of course
 799 'JPG'  => "image/jpeg",
 800 'JPEG' => "image/jpeg",
 801 'GIF'  => "image/gif",
 802 'AU'   => "audio/basic",
 803 'AIF'  => "audio/aiff",
 804 'AIFC' => "audio/aiff",
 805 'AIFF' => "audio/aiff",
 806 'GZ'   => "application/gzip",
 807 'TGZ'   => "application/tar",
 808 #'CGI'  => "text/osshell",       # Executes SERVER side shell scripts, HIGHLY DANGEROUS
 809 'WAV'  => "audio/wav",
 810 'OGG'  => "audio/x-vorbis",
 811 'PDF'  => "application/pdf",
 812 'PS'  => "application/postscript"
 813 );
 814
 815 ################################################
 816 #                                              #
 817 #   Fill the RAM image of the web site         #
 818 #                                              #
 819 ################################################
 820
 821 my %WWWramImage = ();
 822 if($UseRAMimage)
 823 {
 824         my  $TotalSize = 0;
 825         my @WWWfilelist = `find $textroot ! -type l ! -type d -print`;
 826         my $WWWfile;
 827         foreach $WWWfile (@WWWfilelist)
 828         {
 829                 chomp($WWWfile);
 830                 # Skip unsupported file types
 831                 $WWWfile =~ /\.(\w+)$/;
 832                 my $WWWfileExtension = uc($1);
 833                 next unless $mimeType{$WWWfileExtension};
 834                 # Store GnuZipped image of file
 835                 $WWWramImage{$WWWfile} = "";
 836                 open(FILEIN, "<$WWWfile") || die "$WWWfile could not be opened: $!\n";
 837                 my $Buffer;
 838                 while(sysread(FILEIN, $Buffer, 1024))
 839                 {
 840                     $WWWramImage{$WWWfile} .= $Buffer;
 841                 };
 842                 # Apply compression
 843                 my $CompressedPtr = &$CompressRAMimage(\${WWWramImage{$WWWfile}});
 844                 $WWWramImage{$WWWfile} = $$CompressedPtr;
 845                 $TotalSize += length($WWWramImage{$WWWfile});
 846         };
 847         #
 848         # Report size of Web RAM image
 849         print STDERR "Total number of $TotalSize bytes read in memory image\n";
 850 };
 851
 852 ################################################
 853 #                                              #
 854 #   The RAM image of the web site has been     #
 855 #   filled.                                    #
 856 #                                              #
 857 ################################################
 858
 859 # Map HTTP request parameters to Environment variables
 860 # HTTP request => Environment variable
 861 my %HTTPtype = (
 862 'content-length'  => 'CONTENT_LENGTH',    # Necessary for POST
 863 'user-agent'      => 'HTTP_USER_AGENT',
 864 'accept'          => 'HTTP_ACCEPT',
 865 'content-type'    => 'CONTENT_TYPE',
 866 'auth-type'       => 'AUTH_TYPE',
 867 'ident'           => 'REMOTE_IDENT',
 868 'referer'         => 'HTTP_REFERER',
 869 'user'            => 'REMOTE_USER',
 870 'address'         => 'REMOTE_ADDR',
 871 'connection'      => 'HTTP_CONNECTION',
 872 'accept-language' => 'HTTP_ACCEPT_LANGUAGE',
 873 'accept-encoding' => 'HTTP_ACCEPT_ENCODING',
 874 'accept-charset'  => 'HTTP_ACCEPT_CHARSET',
 875 'host'            => 'HTTP_HOST',
 876 'cookie'          => 'COOKIE_JAR'
 877 );
 878
 879 ###############################################################################
 880 #                                                                             #
 881 #  Now we start with the real work. When there is a request, get the required #
 882 #  values and fork a child to service it.                                     #
 883 #                                                                             #
 884 ###############################################################################
 885
 886 my @brood = ();
 887 my %StartTime = ();             # Start time of the children
 888 my $child;
 889
 890 # When someone knocks on the door
 891 for (;;)
 892 {
 893     my $paddr;
 894
 895     if(!($paddr = accept(Client,Server)) ) # Knock knock
 896     {
 897         exit 1; # This went terrribly wrong
 898     };
 899
 900     # Fork to child and parent
 901     if(($child =fork()) == 0)
 902     {
 903         # this is the child
 904         my ($port,$iaddr) = sockaddr_in($paddr);
 905         my $address = inet_ntoa($iaddr);  # The IP address of the Client
 906         # The following is EXTREMELY slow and generally unnecessary.
 907         # Use -n  or set $NONAME = 1; if you don't need it.
 908         my $name = $NONAME ? '' : gethostbyaddr($iaddr,AF_INET);
 909         my @Input = ();
 910
 911         #
 912         # Before doing anything else, check whether the client should be
 913         # served at all.
 914         # Is IP addr on the list?
 915         if(@RemoteAddr && !grep(/^\Q$address\E/, @RemoteAddr))
 916         {
 917             print STDERR "Reject $address $name\n";
 918             exit 1;
 919         };
 920         # Is name on the list?
 921         if(@RemoteHost && !grep(/\Q$name\E$/, @RemoteHost))
 922         {
 923             print STDERR "Reject $name $address\n";
 924             exit 1;
 925         };
 926
 927         #
 928         # Grab a line without using buffered input... Important for
 929         # Post methods since they have to read the Client input stream.
 930         #
 931         my $string = "";
 932         my $ch = "";
 933         my $HTTPlength = 0;
 934         alarm 120 ;     # prevent deadly spin if other end goes away
 935         while(sysread(Client, $ch, 1)>0)
 936         {
 937             $string .= $ch;
 938             ++$HTTPlength;
 939             last if $HTTPlength > $MaxLength;  # Protect against overflow
 940
 941             next if $ch eq "\r"; # skip <cr>
 942             if($ch eq "\n")
 943             {
 944                         last unless $string =~ /\S/;        # stop if empty line
 945                         push (@Input, split(' ', $string)); # Collect input in list
 946                         $string = "";
 947             };
 948         };
 949         alarm 0;    # clear alarm
 950
 951                 # Reset %ENV
 952                 foreach my $varname (keys(%FrozenEnv))
 953                 {
 954                         $ENV{$varname} = $FrozenEnv{$varname};
 955                 };
 956
 957         # Extract input arguments
 958         my $method   = shift(@Input);
 959         my $Request  = shift(@Input);
 960         my $protocol = shift(@Input);
 961         my ($Path, $QueryString) = split('\?', $Request);
 962
 963         # Get rest of Input
 964         my $HTTPparameter;
 965         my %HTTPtable = ();
 966         while($HTTPparameter = lc(shift(@Input)))
 967         {
 968             chop($HTTPparameter);
 969             $HTTPtable{$HTTPparameter} = "";
 970             while(@Input && $Input[0] !~ /\:$/)
 971             {
 972                 $HTTPtable{$HTTPparameter} .= " " if  $HTTPtable{$HTTPparameter};
 973                 $HTTPtable{$HTTPparameter} .= shift(@Input);
 974             };
 975         };
 976         # Host can get the :SERVER_PORT appended. Set the correct SERVER_PORT
 977         # and remove it from the host.
 978         if($HTTPtable{'host'})
 979         {
 980             # Store current port number
 981             if($HTTPtable{'host'} =~ /\:(\d+)\s*$/)
 982             {
 983                 $ENV{'SERVER_PORT'} = $1;
 984             };
 985             # Remove port number from host
 986             $HTTPtable{'host'} =~ s/\:(\d+)\s*$//g;
 987         };
 988
 989         # Translate the Aliases
 990             $Path = GetAlias($Path);
 991
 992         # HTTP servers should always add the default path
 993         $Path = $welcome if !$Path || $Path eq '/';     # The common default path
 994
 995         # Set fixed environment variables
 996         $ENV{'PATH_INFO'}       = "$Path";
 997         $ENV{'QUERY_STRING'}    = "$QueryString";
 998         $ENV{'PATH_TRANSLATED'} = "$textroot$Path";
 999         $ENV{'SERVER_PROTOCOL'} = "$protocol";
1000         $ENV{'REQUEST_METHOD'}  = "$method";
1001         $ENV{'REMOTE_ADDR'}     = "$address";  # The IP address of the Client
1002         $ENV{'REMOTE_HOST'}     = "$name";
1003
1004         # Load all request information in the %ENV.
1005         # MUST be done with a pre-defined list of parameter names (security).
1006         foreach $HTTPparameter (keys(%HTTPtype))
1007         {
1008             my $Label = $HTTPtype{$HTTPparameter};
1009             # The following adds environment variables FROM THE REQUEST.
1010             # It is a VERY, VERY bad idea to just use the client supplied
1011             # parameter names!
1012             $ENV{$Label} = $HTTPtable{$HTTPparameter} unless exists($ENV{$Label});
1013             # (The last part prevents overwriting existing environment variables)
1014         };
1015
1016         # SECURITY: Check length of POST request. Stop if request is too long
1017         die if $HTTPlength + $ENV{'CONTENT_LENGTH'} > $MaxLength;
1018
1019         # If POST requests are unwanted, they can be added tot the query string
1020         # NOTE: the method is set to GET if $POSTtoGET equals 'GET', otherwise,
1021         # the method stays POST and only the content length is set to 0
1022         if($POSTtoGET && $ENV{'REQUEST_METHOD'} =~ /^POST$/i)
1023         {
1024                 my $POSTlength = $ENV{'CONTENT_LENGTH'} || 0;
1025                 my $ReadBytes = 1;
1026
1027                 # Add '&' if there is a query string already
1028                 if($ENV{'QUERY_STRING'})
1029                 {
1030                         # Before we add something to the string, check length again
1031                 die if $HTTPlength + $ENV{'CONTENT_LENGTH'} + 1 > $MaxLength;
1032                         # Now add the '&'
1033                         $ENV{'QUERY_STRING'} .= '&';
1034                 };
1035
1036                 # Read Client
1037                 while($POSTlength > 0 && $ReadBytes > 0)
1038                 {
1039                         my $Read = "";
1040                         $ReadBytes = sysread(Client, $Read, $POSTlength);
1041                         $ENV{'QUERY_STRING'} .= $Read;
1042                         $POSTlength -= $ReadBytes;
1043                 };
1044
1045                 # All has been read, the content length becomes 0
1046                 $ENV{'CONTENT_LENGTH'} = 0;
1047                 # Method can change
1048                 $ENV{'REQUEST_METHOD'} = 'GET' if $POSTtoGET eq 'GET';
1049         };
1050
1051                 # Reset User defience Env variables
1052                 foreach my $varname (keys(%UserEnv))
1053                 {
1054                         $ENV{$varname} = $UserEnv{$varname};
1055                 };
1056                 # Clean out the User Environment variables in the child
1057                 %UserEnv = ();
1058
1059         #
1060         # Connect STDOUT and STDIN to the client
1061         open(STDIN, "<&Client");
1062         open(STDOUT, ">&Client");
1063         print STDOUT "HTTP/1.1 200 OK\n";       # Supply HTTP protocol information
1064             print STDOUT "Date: ".gmtime()." GMT\n"; # Current date
1065             print STDOUT "Server: $program $version\n"; # This program
1066             print STDOUT "Connection: close\n"; # Don't allow persistent connections
1067
1068         # Start processing of request (note that ALL scripts will be executed if
1069         # present, i.e., if -d, -x, and -e are entered, they are alle processed).
1070
1071         # If in memory-only mode, store the requested file in an environment
1072         # variable: CGI_FILE_CONTENTS
1073         undef($ENV{'CGI_FILE_CONTENTS'}); # Make sure the ENV var doesn't exist
1074         if($UseRAMimage)
1075         {
1076             my $DecompressedPtr = &$DecompressRAMimage(\${WWWramImage{"$textroot$Path"}});
1077             $ENV{'CGI_FILE_CONTENTS'} = $$DecompressedPtr;
1078             # Decompression does not seem to work
1079         };
1080
1081         # do perl script
1082         @ARGV = ("$textroot$Path", $QueryString);
1083         # This was suggested by Jochen_Hayek@ACM.org
1084         if($doarg)
1085         {
1086             # The perl script should do the printing
1087             my ($return) = do "$doarg";
1088
1089             warn "couldn't parse $doarg: $@" if $@;
1090             warn "couldn't $doarg: $!" unless defined $return;
1091             warn "couldn't run $doarg" unless $return;
1092         };
1093
1094         # evaluate perl command
1095         print STDOUT eval($evalarg) if $evalarg;
1096
1097         # execute shell command
1098         if($execarg)
1099         {
1100             my $shellscript = $execarg;
1101
1102             # Attempts to use Paths or Queries containing '-quotes are rejected.
1103             # Executing these would compromise security.
1104             die "Quotes in path: $textroot$Path\n" if "$textroot$Path" =~ /\'/;
1105             $shellscript .= " '$textroot$Path'" if $Path;
1106
1107             die "Quotes in query: $QueryString\n" if $QueryString =~ /\'/;
1108             $shellscript .= " '$QueryString'" if $QueryString;
1109             $shellscript = qx{$shellscript};
1110             print STDOUT $shellscript;
1111         };
1112
1113         # Output files if no scripts are given (actually, this should be
1114         # handled by a script). Unknown mimetypes are killed.
1115         # This is more or less a functional (dynamic) Web server in itself.
1116         unless($doarg || $execarg || $evalarg) # Request not already handled
1117         {
1118             die ".. trick: $address $name $Path $QueryString\n"
1119                 if $Path =~ m@\.\./@ ;      # No tricks!
1120
1121                 # Handle mime-types and directory browsing
1122             $Path =~ /\.([\w]+)$/;      # Get extension
1123             my $extension = uc($1);
1124                 my $browse = ($Path =~ m@/\s*$@ || -d "$textroot$Path") ? 1 : 0;
1125             my $mime = $browse ? "" : $mimeType{$extension};
1126
1127                 # Serve up text and binary files unless they the $Secure option is given
1128                 $mime = "text/plain" if !$mime && !$browse && (-T "$textroot$Path") && !$Secure;
1129                 $mime = "application/octet-stream" if !$mime && !$browse && (-B "$textroot$Path") && !$Secure;
1130
1131                 # Remove final / in directory paths
1132                 $Path =~ s@/\s*$@@g;
1133
1134                 # Block illegal mime-types
1135                 die "Illegal mime type:$extension\n" unless $mime || $browse; # illegal mime's are killed
1136
1137             # Print out the document
1138             if(($mime eq 'text/osshell') && $ExecuteOSshell) # Don't use this unless you know what you're doing
1139             {
1140                 # Note that CGI scripts must supply their own content type
1141                 # Some rudimentary security tests
1142                 # Kill child if the path contains any non-URL characters
1143                 die "ATTACK: ADDR:$ENV{'REMOTE_ADDR'} HOST:$ENV{'REMOTE_HOST'} URL=$Path '$QueryString'\n"
1144                 if $Path =~ m@[^\w\-\.\/]@;     # Exclusive list of allowed characters
1145                 # If you want to execute server side shell scripts, use the 'text/osshell'
1146                 # mime-type (see above) but remember that there is NO SECURITY implemented
1147                 # whatsoever.
1148                 # IF YOU DIDN'T GET THE MESSAGE YET, YOU COULD NOW OPEN YOUR COMPUTER TO THE WHOLE
1149                 # INTERNET TO PLAY WITH!
1150                 # Plain Web site from DISK
1151                 unless($UseRAMimage)
1152                 {
1153                     print STDOUT `$textroot$Path`;  # This is Russian Roulette
1154                 }
1155                 else  # Use a RAM image of the web site
1156                 {
1157                     my $ShellInterpreter = '/usr/bin/sh';
1158                     if($ENV{'CGI_FILE_CONTENTS'} =~ /^\#\!\s*([^\r\n]+)/isg)
1159                     {
1160                         $ShellInterpreter = $1;
1161                     };
1162                     # Execute shell script
1163                     open(RAMOUT, "| $ShellInterpreter") || die "ERROR open RAMOUT  $ShellInterpreter $textroot$Path $! $@\n";
1164                     (print RAMOUT $ENV{'CGI_FILE_CONTENTS'}) || die "ERROR print RAMOUT $ShellInterpreter $textroot$Path $! $@\n";
1165                     close(RAMOUT);
1166                 };
1167             }
1168             elsif($mime)
1169             {
1170                 # Content-type and document
1171                 print STDOUT "Content-type: $mime\n\n";
1172                 # Plain Web site from DISK
1173                 unless($UseRAMimage)
1174                 {
1175                     my $String = "";
1176                     my $number_of_bytes = 0;
1177                     open(BINARY, "<$textroot$Path") || die "$textroot$Path: $!";
1178
1179                     # read and write block of 1024 bytes
1180                     while($number_of_bytes = sysread(BINARY, $String, 1024))
1181                     {
1182                             syswrite(STDOUT, $String, $number_of_bytes); # Actually print the file content
1183                     };
1184                     close(BINARY);
1185
1186 #                   Alternative output using the UNIX shell
1187 #                   print STDOUT `cat '$textroot$Path'`; # lazy, let the OS do the work
1188                 }
1189                 else  # Use a RAM image of the web site
1190                 {
1191                     print STDOUT $ENV{'CGI_FILE_CONTENTS'};
1192
1193                 };
1194                     }
1195                     elsif($browse && !$Secure)  # Block directory browsing in the Secure setup
1196                     {
1197                                 # Content-type and document
1198                     print STDOUT "Content-type: text/html\n\n";
1199                                 opendir(BROWSE, "$textroot$Path") || die "<$textroot$Path: $!\n";
1200
1201                                 print "<HTML>\n<HEAD>\n<TITLE>$Path</TITLE></HEAD>\n<BODY>\n<H1>$Path</H1>\n<pre>\n<dl>";
1202
1203                                 my $DirEntry;
1204                                 foreach $DirEntry (sort {lc($a) cmp lc($b)} readdir(BROWSE))
1205                                 {
1206                                         my $CurrentPath = $Path;
1207                                         # Handle '..'
1208                                         if($DirEntry eq '..')
1209                                         {
1210                                                 my $ParentDir = $CurrentPath;
1211                                                 $ParentDir =~ s@/[^/]+$@@g;
1212                                                 $ParentDir = '/' unless $ParentDir;
1213                                                 print "<dt> <a href='$ParentDir'><h3>Parent directory</h3></a></dt>\n";
1214                                         };
1215                                         next if $DirEntry !~ /[^\.\/\\\:]/;
1216
1217                                         # Get aliases
1218                                         my $Alias = GetAlias("$CurrentPath/$DirEntry");
1219                                         if($Alias ne "$CurrentPath/$DirEntry")
1220                                         {
1221                                                 $Alias =~ m@/([^/]+)$@;
1222                                                 $CurrentPath = $`;
1223                                                 $DirEntry = $1;
1224                                         };
1225                                         #
1226                                         my $Date = localtime($^T - (-M "$textroot$CurrentPath/$DirEntry")*3600*24);
1227                                         my $Size = -s "$textroot$CurrentPath/$DirEntry";
1228                                         $Size = sprintf("%6.0F kB", $Size/1024);
1229                                         my $Type = `file $textroot$CurrentPath/$DirEntry`;
1230                                         $Type =~ s@\s*$textroot$CurrentPath/$DirEntry\s*\:\s*@@ig;
1231                                         chomp($Type);
1232                                         print "<dt> <a href='$CurrentPath/$DirEntry'>";
1233                                         printf("%-40s", $DirEntry."</a>");
1234                                         print "\t$Size\t$Date\t$Type</dt>\n";
1235                                 };
1236                                 close(BROWSE);
1237                                 print "</dl></pre></BODY>\n</HTML>\n";
1238
1239                 };
1240         };
1241
1242         close(STDOUT) || die "STDOUT: $!\n";
1243         close(STDIN) || die "STDIN: $!\n";
1244             close(Client) || die "Client: $!\n";
1245         #
1246         exit 0; # Kill Child
1247     }
1248     else
1249     {
1250         #
1251         # parent code...some systems will have to worry about waiting
1252         # before they can actually close the link to the Client
1253         my $current_time = time();
1254
1255         # Determine which of the children are actually still alive
1256         # and kill those that have run for too long (probably not connected anymore)
1257         my @old_brood = @brood;
1258         @brood = ();    # empty brood
1259         foreach (@old_brood)
1260         {
1261             # Kill the child if it runs for longer than MaxTime
1262             if(($StartTime{$_} - $current_time) > $MaxTime)
1263             {
1264                 kill "KILL", $_;
1265             };
1266
1267             # Store children that are alive
1268             if(kill (0, $_)) # Alive?
1269             {
1270                 push(@brood, $_);
1271             }
1272             else
1273             {
1274                 delete($StartTime{$_});
1275             };
1276         };
1277
1278         # Weed out overflow of children (zombies etc.), keep pid for
1279         # removing the StartTime later on
1280         my $oldest;
1281         for($oldest=0; $oldest < scalar(@brood)-$MaxBrood; ++$oldest)
1282         {
1283             kill "KILL", $brood[$oldest] if $brood[$oldest]; # Remove
1284         };
1285
1286         # Child pid could be recycled, i.e., $child could be stored
1287         # in @brood already. Remove it
1288         @brood = grep($_ != $child, @brood);
1289
1290         # Push new child on the list
1291         push (@brood, $child);
1292         $StartTime{$child} = $current_time;
1293
1294         close Client;  # This is it, ready!
1295     };
1296 };
1297
1298 # Interupt handler for shutting down
1299 sub SigHandler
1300 {
1301     my $sig = shift;
1302     exit 1;
1303 }
1304
1305 # Subroutine for Aliases
1306 # Uses Global variables: %AliasTranslation, @RegAliasTranslation, and @RegURLTranslation
1307 sub GetAlias    # ($Path)->AliasURL
1308 {
1309     my $Path = shift;
1310
1311     # Translate the Aliases
1312     if($AliasTranslation{$Path})
1313     {
1314         $Path = $AliasTranslation{$Path};
1315     }
1316     elsif(@RegAliasTranslation)
1317     {
1318        my $i;
1319        for($i=0; $i<scalar(@RegAliasTranslation); ++$i)
1320        {
1321            my $Alias   = $RegAliasTranslation[$i];
1322            my $RealURL = $RegURLTranslation[$i];
1323            last if ($Path =~ s#$Alias#$RealURL#g);
1324        };
1325     };
1326     return $Path;
1327 }
1328
1329 =head1 NAME
1330
1331 CGIservlet - a HTTPd "connector" for running CGI scripts on unix systems as WWW
1332 accessible Web sites.
1333
1334 =head1 DESCRIPTION
1335
1336 The servlet starts a true HTTP daemon that channels
1337 HTTP requests to forked daughter processes. Can run
1338 a (small) WWW-site from memory.
1339
1340 =head1 README
1341
1342 Whenever an HTTP request is received, the specified CGI script is
1343 started inside a child process as if it was inside a real server (e.g.,
1344 Apache). The evironment variables are set more or less as in Apache.
1345 Note that CGIservlet only uses a SINGLE script for ALL requests.
1346 No attemps for security are made, it is the script's responsibility to
1347 check access rights and the validity of the request.
1348 Can store the files of Web site in memory and serve them
1349 on request.
1350
1351 =head1 PREREQUISITES
1352
1353 This script requires the C<strict>, Socket and Carp modules.
1354
1355 =head1 COREQUISITES
1356
1357 =pod OSNAMES
1358
1359 Unix
1360
1361 =pod SCRIPT CATEGORIES
1362
1363 CGI
1364 Web
1365
1366 =cut