Hello World

handling # 20 May 2003 - Added a --help switch to print the manual. # 06 Mar 2003 - Adapted the blurb at the end of the file. # 03 Mar 2003 - Added a user definable dieHandler function to catch all # "die" calls. Also "enhanced" the STDERR printout. # 10 Feb 2003 - Split off the reading of the POST part of a query # from Initialize_output. This was suggested by Gerd Franke # to allow for the catching of the file_path using a # POST based lookup. That is, he needed the POST part # to change the file_path. # 03 Feb 2003 - %{$name}; => %{$name} = (); in defineCGIvariableHash. # 03 Feb 2003 - \1 better written as $1 in # $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g # 29 Jan 2003 - This makes "CLASS="ssperl" CSS-compatible Gerd Franke # added: # $ServerScriptContentClass = "ssperl"; # changed in ProcessFile(): # unless(($CurrentContentType =~ # 28 Jan 2003 - Added 'INS' Tag! Gerd Franke # 20 Dec 2002 - Removed useless $Directoryseparator variable. # Update comments and documentation. # 18 Dec 2002 - Corrected bug in Accept/Reject processing. # Files didn't work. # 24 Jul 2002 - Added .htaccess documentation (from Gerd Franke) # Also added a note that RawFilePattern can be a # complete file name. # 19 Mar 2002 - Added SRC pseudo-files PREFIX and POSTFIX. These # switch to prepending or to appending the content # of the SRC attribute. Default is prefixing. You # can add as many of these switches as you like. # 13 Mar 2002 - Do not search for tag content if a tag closes with # />, i.e.,

will be handled the XML/XHTML way. # 25 Jan 2002 - Added 'curl' and 'snarf' to SRC attribute URL handling # (replaces wget). # 25 Jan 2002 - Found a bug in SAFEqx, now executes qx() in a scalar context # (i.o. a list context). This is necessary for binary results. # 24 Jan 2002 - Disambiguated -T $SRCfile to -T "$SRCfile" (and -e) and # changed the order of if/elsif to allow removing these # conditions in systems with broken -T functions. # (I also removed a spurious ')' bracket) # 17 Jan 2002 - Changed DIV tag SRC from to sysread(SOURCE,...) # to support binary files. # 17 Jan 2002 - Removed WhiteSpace from $FileAllowedCharacters. # 17 Jan 2002 - Allow "file://" prefix in SRC attribute. It is simply # stipped from the path. # 15 Jan 2002 - Version 2.2 # 15 Jan 2002 - Debugged and completed URL support (including # CGIscriptor::read_url() function) # 07 Jan 2002 - Added automatic (magic) URL support to the SRC attribute # with the main::GET_URL function. Uses wget -O underlying. # 04 Jan 2002 - Added initialization of $NewDirective in InsertForeignScript # (i.e., my $NewDirective = "";) to clear old output # (this was a realy anoying bug). # 03 Jan 2002 - Added a

# tags that assign the body text as-is (literally) # to $varname. Allows standard HTML-tools to handle # Cascading Style Sheet templates. This implements a # design by Gerd Franke (franke@roo.de). # 03 Jan 2002 - I finaly gave in and allowed SRC files to expand ~/. # 12 Oct 2001 - Normalized spelling of "CGIsafFileName" in documentation. # 09 Oct 2001 - Added $ENV{'CGI_BINARY_FILE'} to log files to # detect unwanted indexing of TAR files by webcrawlers. # 10 Sep 2001 - Added $YOUR_SCRIPTS directory to @INC for 'require'. # 22 Aug 2001 - Added .txt (Content-type: text/plain) as a default # processed file type. Was processed via BinaryMapFile. # 31 May 2001 - Changed =~ inside CGIsafeEmailAddress that was buggy. # 29 May 2001 - Updated $CGI_HOME to point to $ENV{DOCUMENT_ROOT} io # the root of PATH_TRANSLATED. DOCUMENT_ROOT can now # be manipulated to achieve a "Sub Root". # NOTE: you can have $YOUR_HTML_FILES != DOCUMENT_ROOT # 28 May 2001 - Changed CGIscriptor::BrowsDirs function for security # and debugging (it now works). # 21 May 2001 - defineCGIvariableHash will ADD values to existing # hashes,instead of replacing existing hashes. # 17 May 2001 - Interjected a '&' when pasting POST to GET data # 24 Apr 2001 - Blocked direct requests for BinaryMapFile. # 16 Aug 2000 - Added hash table extraction for CGI parameters with # CGIparseValueHash (used with structured parameters). # Use: CGI='%' (fill in your name in <>) # Will collect all =value pairs in # ${} = value; # 16 Aug 2000 - Adapted SAFEqx to protect @PARAMETER values. # 09 Aug 2000 - Added support for non-filesystem input by way of # the CGI_FILE_CONTENTS and CGI_DATA_ACCESS_CODE # environment variables. # 26 Jul 2000 - On the command-line, file-path '-' indicates STDIN. # This allows CGIscriptor to be used in pipes. # Default, $BLOCK_STDIN_HTTP_REQUEST=1 will block this # in an HTTP request (i.e., in a web server). # 26 Jul 2000 - Blocked 'Content-type: text/html' if the SERVER_PROTOCOL # is not HTTP or another protocol. Changed the default # source directory to DOCUMENT_ROOT (i.o. the incorrect # SERVER_ROOT). # 24 Jul 2000 - -slim Command-line argument added to remove all # comments, security, etc.. Updated documentation. # 05 Jul 2000 - Added IF and UNLESS attributes to make the # execution of all and # # or # # # # construct (anything between []-brackets is optional, other MIME-types # and scripting languages are supported), the embedded script is removed # and both the contents of the source file (i.e., "do 'ScriptSource'") # AND the script are evaluated as a PERL program (i.e., by eval()), # shell script (i.e., by a "safe" version of `Command`, qx) or an external # interpreter. The output of the eval() function takes the place of the # original construct in the output string. Any CGI # parameters declared by the CGI attribute are available as simple perl # variables, and can subsequently be made available as variables to other # scripting languages (e.g., bash, python, or lisp). # # Example: printing "Hello World" # Hello World # #

# # # Save this in a file, hello.html, in the directory you indicated with # $YOUR_HTML_FILES and access http://your_server/SHTML/hello.html # (or to whatever name you use as an alias for CGIscriptor.pl). # This is realy ALL you need to do to get going. # # You can use any values that are delivered in CGI-compliant form (i.e., # the "?name=value" type URL additions) transparently as "$name" variables # in your scripts IFF you have declared them in the CGI attribute of # a META or SCRIPT tag before e.g.: # # or # # is #

# # # # The output could look like the following (in HTML-speak): # # # The Answer to your question #

What is the capital of the Netherlands?

# is #

Amsterdam

# #

# Next question:
# # # Note that the function "Answer.pl" does know nothing about CGI or HTML, # it just prints out answers to arguments. Likewise, the text has no # provisions for scripts or CGI like constructs. Also, it is completely # trivial to extend this "program" to use the "Answer" later in the page # to call up other information or pictures/sounds. The final text never # shows any cue as to what the original "source" looked like, i.e., # where you store your scripts and how they are called. # # There are some extra's. The argument of the files called in a SRC= tag # can access the CGI variables declared in the preceding META tag from # the @ARGV array. Executable files are called as: # `file '$ARGV[0]' ... ` (e.g., `Answer.pl \'$Question\'`;) # The files called from SRC can even be (CGIscriptor) html files which are # processed in-line. Furthermore, the SRC= tag can contain a perl block # that is evaluated. That is, # # will result in the evaluation of "print do {$Question};" and the VALUE # of $Question will be printed. Note that these "SRC-blocks" can be # preceded and followed by other file names, but only a single block is # allowed in a SRC= tag. # # One of the major hassles of dynamic WWW pages is the fact that several # mutually incompatible browsers and platforms must be supported. For example, # the way sound is played automatically is different for Netscape and # Internet Explorer, and for each browser it is different again on # Unix, MacOS, and Windows. Realy dangerous is processing user-supplied # (form-) values to construct email addresses, file names, or database # queries. All Apache WWW-server exploits reported in the media are # based on faulty CGI-scripts that didn't check their user-data properly. # # There is no panacee for these problems, but a lot of work and problems # can be saved by allowing easy and transparent control over which # blocks are executed on what CGI-data. CGIscriptor # supplies such a method in the form of a pair of attributes: # IF='...condition..' and UNLESS='...condition...'. When added to a # script tag, the whole block (including the SRC attribute) will be # ignored if the condition is false (IF) or true (UNLESS). # For example, the following block will NOT be evaluated if the value # of the CGI variable FILENAME is NOT a valid filename: # # # # (the function CGIsafeFileName(String) returns an empty string ("") # if the String argument is not a valid filename). # The UNLESS attribute is the mirror image of IF. # # A user manual follows the HTML 4 and security paragraphs below. # ########################################################################## # # HTML 4 compliance # # In general, CGIscriptor.pl complies with the HTML 4 recommendations of # the W3C. This means that any software to manage Web sites will be able # to handle CGIscriptor files, as will web agents. # # All script code should be placed between tags, the # script type is indicated with TYPE="mime-type", the LANGUAGE # feature is ignored, and a SRC feature is implemented. All CGI specific # features are delegated to the CGI attribute. # # However, the behavior deviates from the W3C recommendations at some # points. Most notably: # 0- The scripts are executed at the server side, invissible to the # client (i.e., the browser) # 1- The mime-types are personal and idiosyncratic, but can be adapted. # 2- Code in the body of a tag-pair is still evaluated # when a SRC feature is present. # 3- The SRC attribute reads a list of files. # 4- The files in a SRC attribute are processed according to file type. # 5- The SRC attribute evaluates inline Perl code. # 6- Processed META, DIV, INS tags are removed from the output # document. # 7- All attributes of the processed META tags, except CONTENT, are ignored # (i.e., deleted from the output). # 8- META tags can be placed ANYWHERE in the document. # 9- Through the SRC feature, META tags can have visible output in the # document. # 10- The CGI attribute that declares CGI parameters, can be used # inside the TAG CONSTRUCT. # # The reason for the IF, UNLESS, and SRC attributes (and their Perl code # evaluation) were build into the META and SCRIPT tags is part laziness, # part security. The SRC blocks allows more compact documents and easier # debugging. The values of the CGI variables can be immediately screened # for security by IF or UNLESS conditions, and even SRC attributes (e.g., # email addresses and file names), and a few commands can be called # without having to add another Perl TAG pair. This is especially important # for documents that require the use of other (more restricted) "scripting" # languages and facilities that lag transparent control structures. # ########################################################################## # # SECURITY # # Your WWW site is a few keystrokes away from a few hundred million internet # users. A fair percentage of these users knows more about your computer # than you do. And some of these just might have bad intentions. # # To ensure uncompromized operation of your server and platform, several # features are incorporated in CGIscriptor.pl to enhance security. # First of all, you should check the source of this program. No security # measures will help you when you download programs from anonymous sources. # If you want to use THIS file, please make sure that it is uncompromized. # The best way to do this is to contact the source and try to determine # whether s/he is reliable (and accountable). # # BE AWARE THAT ANY PROGRAMMER CAN CHANGE THIS PROGRAM IN SUCH A WAY THAT # IT WILL SET THE DOORS TO YOUR SYSTEM WIDE OPEN # # I would like to ask any user who finds bugs that could compromise # security to report them to me (and any other bug too, # Email: R.J.J.H.vanSon@gmail.com or ifa@hum.uva.nl). # # Security features # # 1 Invisibility # The inner workings of the HTML source files are completely hidden # from the client. Only the HTTP header and the ever changing content # of the output distinguish it from the output of a plain, fixed HTML # file. Names, structures, and arguments of the "embedded" scripts # are invisible to the client. Error output is suppressed except # during debugging (user configurable). # # 2 Separate directory trees # Directories containing Inline text and script files can reside on # separate trees, distinct from those of the HTTP server. This means # that NEITHER the text files, NOR the script files can be read by # clients other than through CGIscriptor.pl, UNLESS they are # EXPLICITELY made available. # # 3 Requests are NEVER "evaluated" # All client supplied values are used as literal values (''-quoted). # Client supplied ''-quotes are ALWAYS removed. Therefore, as long as the # embedded scripts do NOT themselves evaluate these values, clients CANNOT # supply executable commands. Be sure to AVOID scripts like: # # # # # These are a recipe for disaster. However, the following quoted # form should be save (but is still not adviced): # # # # A special function, SAFEqx(), will automatically do exactly this, # e.g., SAFEqx('ls -1 $UserValue') will execute `ls -1 \'$UserValue\'` # with $UserValue interpolated. I recommend to use SAFEqx() instead # of backticks whenever you can. The OS shell scripts inside # # # # are handeld by SAFEqx and automatically ''-quoted. # # 4 Logging of requests # All requests can be logged separate from the Host server. The level of # detail is user configurable: Including or excluding the actual queries. # This allows for the inspection of (im-) proper use. # # 5 Access control: Clients # The Remote addresses can be checked against a list of authorized # (i.e., accepted) or non-authorized (i.e., rejected) clients. Both # REMOTE_HOST and REMOTE_ADDR are tested so clients without a proper # HOST name can be (in-) excluded by their IP-address. Client patterns # containing all numbers and dots are considered IP-addresses, all others # domain names. No wild-cards or regexp's are allowed, only partial # addresses. # Matching of names is done from the back to the front (domain first, # i.e., $REMOTE_HOST =~ /\Q$pattern\E$/is), so including ".edu" will # accept or reject all clients from the domain EDU. Matching of # IP-addresses is done from the front to the back (domain first, i.e., # $REMOTE_ADDR =~ /^\Q$pattern\E/is), so including "128." will (in-) # exclude all clients whose IP-address starts with 128. # There are two special symbols: "-" matches HOSTs with no name and "*" # matches ALL HOSTS/clients. # For those needing more expressional power, lines starting with # "-e" are evaluated by the perl eval() function. E.g., # '-e $REMOTE_HOST =~ /\.edu$/is;' will accept/reject clients from the # domain '.edu'. # # 6 Access control: Files # In principle, CGIscriptor could read ANY file in the directory # tree as discussed in 1. However, for security reasons this is # restricted to text files. It can be made more restricted by entering # a global file pattern (e.g., ".html"). This is done by default. # For each client requesting access, the file pattern(s) can be made # more restrictive than the global pattern by entering client specific # file patterns in the Access Control files (see 5). # For example: if the ACCEPT file contained the lines # * DEMO # .hum.uva.nl LET # 145.18.230. # Then all clients could request paths containing "DEMO" or "demo", e.g. # "/my/demo/file.html" ($PATH_INFO =~ /\Q$pattern\E/), Clients from # *.hum.uva.nl could also request paths containing "LET or "let", e.g. # "/my/let/file.html", and clients from the local cluster # 145.18.230.[0-9]+ could access ALL files. # Again, for those needing more expressional power, lines starting with # "-e" are evaluated. For instance: # '-e $REMOTE_HOST =~ /\.edu$/is && $PATH_INFO =~ m@/DEMO/@is;' # will accept/reject requests for files from the directory "/demo/" from # clients from the domain '.edu'. # # 7 Access control: Server side session tickets # Specific paths can be controlled by Session Tickets which must be # present as a SESSIONTICKET= CGI variable in the request. These paths # are defined in %TicketRequiredPatterns as pairs of: # ('regexp' => 'SessionPath\tPasswordPath\tLogin.html\tExpiration'). # Session Tickets are stored in a separate directory (SessionPath, e.g., # "Private/.Session") as files with the exact same name of the SESSIONTICKET # CGI. The following is an example: # Type: SESSION # IPaddress: 127.0.0.1 # AllowedPaths: ^/Private/Name/ # Expires: 3600 # Username: test # ... # Other content can follow. # # It is adviced that Session Tickets should be deleted # after some (idle) time. The IP address should be the IP number at login, and # the SESSIONTICKET will be rejected if it is presented from another IP address. # AllowedPaths and DeniedPaths are perl regexps. Be careful how they match. Make sure to delimit # the names to prevent access to overlapping names, eg, "^/Private/Rob" will also # match "^/Private/Robert", however, "^/Private/Rob/" will not. Expires is the # time the ticket will remain valid after creation (file ctime). Time can be given # in s[econds] (default), m[inutes], h[hours], or d[ays], eg, "24h" means 24 hours. # None of these need be present, but the Ticket must have a non-zero size. # # Next to Session Tickets, there are two other type of ticket files: # - LOGIN tickets store information about a current login request # - PASSWORD ticket store account information to authorize login requests # # 8 Query length limiting # The length of the Query string can be limited. If CONTENT_LENGTH is larger # than this limit, the request is rejected. The combined length of the # Query string and the POST input is checked before any processing is done. # This will prevent clients from overloading the scripts. # The actual, combined, Query Size is accessible as a variable through # $CGI_Content_Length. # # 9 Illegal filenames, paths, and protected directories # One of the primary security concerns in handling CGI-scripts is the # use of "funny" characters in the requests that con scripts in executing # malicious commands. Examples are inserting ';', null bytes, or # characters in URL's and filenames, followed by executable commands. A # special variable $FileAllowedChars stores a string of all allowed # characters. Any request that translates to a filename with a character # OUTSIDE this set will be rejected. # In general, all (readable files) in the DocumentRoot tree are accessible. # This might not be what you want. For instance, your DocumentRoot directory # might be the working directory of a CVS project and contain sensitive # information (e.g., the password to get to the repository). You can block # access to these subdirectories by adding the corresponding patterns to # the $BlockPathAccess variable. For instance, $BlockPathAccess = '/CVS/' # will block any request that contains '/CVS/' or: # die if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@; # #10 The execution of code blocks can be controlled in a transparent way # by adding IF or UNLESS conditions in the tags themselves. That is, # a simple check of the validity of filenames or email addresses can # be done before any code is executed. # ############################################################################### # # USER MANUAL (sort of) # # CGIscriptor removes embedded scripts, indicated by an HTML 4 type # or constructs. CGIscriptor also recognizes XML-type # construct # in the output file. You can use the values that are delivered in # CGI-compliant form (i.e., the "?name=value&.." type URL additions) # transparently as "$name" variables in your directives after they are # defined in a or # # (This will print a "-" if REMOTE_HOST is not known) # Another way to do this is: # # # # or # # # This is possible because ALL environment variables are available as # CGI variables. The environment variables take precedence over CGI # names in case of a "name clash". For instance: # # Will print the current HOME directory (environment) irrespective whether # there is a CGI variable from the query # (e.g., Where do you live? ) # THIS IS A SECURITY FEATURE. It prevents clients from changing # the values of defined environment variables (e.g., by supplying # a bogus $REMOTE_ADDR). Although $ENV{} is not changed by the META tags, # it would make the use of declared variables insecure. You can still # access CGI variables after a name clash with # CGIscriptor::CGIparseValue(). # # Some CGI variables are present several times in the query string # (e.g., from multiple selections). These should be defined as # @VARIABLENAME=default in the CGI attribute. The list @VARIABLENAME # will contain ALL VARIABLENAME values from the query, or a single # default value. If there is an ENVIRONMENT variable of the # same name, it will be used instead of the default AND the query # values. The corresponding function is # CGIscriptor::CGIparseValueList() # # CGI variables collected in a @VARIABLENAME list are unordered. # When more structured variables are needed, a hash table can be used. # A variable defined as %VARIABLE=default will collect all # CGI-parameters whose name start with 'VARIABLE' in a hash table with # the remainder of the name as a key. For instance, %PERSON will # collect PERSONname='John Doe', PERSONbirthdate='01 Jan 00', and # PERSONspouse='Alice' into a hash table %PERSON such that $PERSON{'spouse'} # equals 'Alice'. Any default value or environment value will be stored # under the "" key. If there is an ENVIRONMENT variable of the same name, # it will be used instead of the default AND the query values. The # corresponding function is CGIscriptor::CGIparseValueHash() # # This method of first declaring your environment and CGI variables # before being able to use them in the scripts might seem somewhat # clumsy, but it protects you from inadvertedly printing out the values of # system environment variables when their names coincide with those used # in the CGI forms. It also prevents "clients" from supplying CGI # parameter values for your private variables. # THIS IS A SECURITY FEATURE! # # # NON-HTML CONTENT TYPES # # Normally, CGIscriptor prints the standard "Content-type: text/html\n\n" # message before anything is printed. This has been extended to include # plain text (.txt) files, for which the Content-type (MIME type) # 'text/plain' is printed. In all other respects, text files are treated # as HTML files (this can be switched off by removing '.txt' from the # $FilePattern variable) . When the content type should be something else, # e.g., with multipart files, use the $RawFilePattern (.xmr, see also next # item). CGIscriptor will not print a Content-type message for this file # type (which must supply its OWN Content-type message). Raw files must # still conform to the and tag specifications. # # # NON-HTML FILES # # CGIscriptor is intended to process HTML and text files only. You can # create documents of any mime-type on-the-fly using "raw" text files, # e.g., with the .xmr extension. However, CGIscriptor will not process # binary files of any type, e.g., pictures or sounds. Given the sheer # number of formats, I do not have any intention to do so. However, # an escape route has been provided. You can construct a genuine raw # (.xmr) text file that contains the perl code to service any file type # you want. If the global $BinaryMapFile variable contains the path to # this file (e.g., /BinaryMapFile.xmr), this file will be called # whenever an unsupported (non-HTML) file type is requested. The path # to the requested binary file is stored in $ENV('CGI_BINARY_FILE') # and can be used like any other CGI-variable. Servicing binary files # then becomes supplying the correct Content-type (e.g., print # "Content-type: image/jpeg\n\n";) and reading the file and writing it # to STDOUT (e.g., using sysread() and syswrite()). # # # THE META TAG # # All attributes of a META tag are ignored, except the # CONTENT='text/ssperl; CGI=" ... " [SRC=" ... "]' attribute. The string # inside the quotes following the CONTENT= indication (white-space is # ignored, "" '' `` (){}[]-quote pairs are allowed, plus their \ versions) # MUST start with any of the CGIscriptor mime-types (e.g.: text/ssperl or # text/osshell) and a comma or semicolon. # The quoted string following CGI= contains a white-space separated list # of declarations of the CGI (and Environment) values and default values # used when no CGI values are supplied by the query string. # # If the default value is a longer string containing special characters, # possibly spanning several lines, the string must be enclosed in quotes. # You may use any pair of quotes or brackets from the list '', "", ``, (), # [], or {} to distinguish default values (or preceded by \, e.g., $...$ # is different from (...)). The outermost pair will always be used and any # other quotes inside the string are considered to be part of the string # value, e.g., # # $Value = {['this' # "and" (this)]} # will result in $Value getting the default value: ['this' # "and" (this)] # (NOTE that the newline is part of the default value!). # # Internally, for defining and initializing CGI (ENV) values, the META # and SCRIPT tags use the functions "defineCGIvariable($name, $default)" # (scalars) and "defineCGIvariableList($name, $default)" (lists). # These functions can be used inside scripts as # "CGIscriptor::defineCGIvariable($name, $default)" and # "CGIscriptor::defineCGIvariableList($name, $default)". # "CGIscriptor::defineCGIvariableHash($name, $default)". # # The CGI attribute will be processed exactly identical when used inside # the # tags. This is quite annoying when you want to use large # HTML templates where you will fill in values. # # For this purpose, CGIscriptor will read the neutral #

or # # tag (in Cascading Style Sheet manner) Note that # "varname" has NO '$' before it, it is a bare name. # Any text between these

or # tags will be assigned to '$varname' # as is (e.g., as a literal). # No processing or interpolation will be performed. # There is also NO nesting possible. Do NOT nest a #

inside a

! Moreover, neither INS nor # DIV tags do ensure a block structure in the final # rendering (i.e., no empty lines). # # Note that

# is handled the XML way. No content is processed, # but varname is defined, and any SRC directives are # processed. # # You can use $varname like any other variable name. # However, $varname is NOT a CGI variable and will be # completely internal to your script. There is NO # interaction between $varname and the outside world. # # To interpolate a DIV derived text, you can use: # $varname =~ s/([\]])/\\\1/g; # Mark ']'-quotes # $varname = eval("qq[$varname]"); # Interpolate all values # # The DIV tags will process IF, UNLESS, CGI and # SRC attributes. The SRC files will be pre-pended to the # body text of the tag. SRC blocks are NOT executed. # # CONDITIONAL PROCESSING: THE 'IF' AND 'UNLESS' ATTRIBUTES # # It is often necessary to include code-blocks that should be executed # conditionally, e.g., only for certain browsers or operating system. # Furthermore, quite often sanity and security checks are necessary # before user (form) data can be processed, e.g., with respect to # email addresses and filenames. # # Checks added to the code are often difficult to find, interpret or # maintain and in general mess up the code flow. This kind of confussion # is dangerous. # Also, for many of the supported "foreign" scripting languages, adding # these checks is cumbersome or even impossible. # # As a uniform method for asserting the correctness of "context", two # attributes are added to all supported tags: IF and UNLESS. # They both evaluate their value and block execution when the # result is (IF) or (UNLESS) in Perl, e.g., # UNLESS='$NUMBER \> 100;' blocks execution if $NUMBER <= 100. Note that # the backslash in the '\>' is removed and only used to differentiate # this conditional '>' from the tag-closing '>'. For symmetry, the # backslash in '\<' is also removed. Inside these conditionals, # ~/ and ./ are expanded to their respective directory root paths. # # For example, the following tag will be ignored when the filename is # invalid: # # # # The IF and UNLESS values must be quoted. The same quotes are supported # as with the other attributes. The SRC attribute is ignored when IF and # UNLESS block execution. # # NOTE: 'IF' and 'UNLESS' always evaluate perl code. # # # THE MAGIC SOURCE ATTRIBUTE (SRC=) # # The SRC attribute inside tags accepts a list of filenames and URL's # separated by "," comma's (or ";" semicolons). # ALL the variable values defined in the CGI attribute are available # in @ARGV as if the file or block was executed from the command line, # in the exact order in which they were declared in the preceding CGI # attribute. # # First, a SRC={}-block will be evaluated as if the code inside the # block was part of a construct, i.e., # "print do { code };'';" or `code` (i.e., SAFEqx('code)). # Only a single block is evaluated. Note that this is processed less # efficiently than blocks. Type of evaluation # depends on the content-type: Perl for text/ssperl and OS shell for # text/osshell. For other mime types (scripting languages), anything in # the source block is put in front of the code block "inside" the tag. # # Second, executable files (i.e., -x filename != 0) are evaluated as: # print `filename \'$ARGV[0]\' \'$ARGV[1]\' ...` # That is, you can actually call executables savely from the SRC tag. # # Third, text files that match the file pattern, used by CGIscriptor to # check whether files should be processed ($FilePattern), are # processed in-line (i.e., recursively) by CGIscriptor as if the code # was inserted in the original source file. Recursions, i.e., calling # a file inside itself, are blocked. If you need them, you have to code # them explicitely using "main::ProcessFile($file_path)". # # Fourth, Perl text files (i.e., -T filename != 0) are evaluated as: # "do FileName;'';". # # Last, URL's (i.e., starting with 'HTTP://', 'FTP://', 'GOPHER://', # 'TELNET://', 'WHOIS://' etc.) are loaded # and printed. The loading and handling of and document header # is done by a command generated by main::GET_URL($URL [, 0]). You can enter your # own code (default is curl, wget, or snarf and some post-processing to add a tag). # # There are two pseudo-file names: PREFIX and POSTFIX. These implement # a switch from prefixing the SRC code/files (PREFIX, default) before the # content of the tag to appending the code after the content of the tag # (POSTFIX). The switches are done in the order in which the PREFIX and # POSTFIX labels are encountered. You can mix PREFIX and POSTFIX labels # in any order with the SRC files. Note that the ORDER of file execution # is determined for prefixed and postfixed files seperately. # # File paths can be preceded by the URL protocol prefix "file://". This # is simply STRIPPED from the name. # # Example: # The request # "http://cgi-bin/Action_Forms.pl/Statistics/Sign_Test.html?positive=8&negative=22 # will result in printing "${SS_PUB}/Statistics/Sign_Test.html" # With QUERY_STRING = "positive=8&negative=22" # # on encountering the lines: # #

" # # This line will be processed as: # "`${SS_SCRIPT}/Statistics/SignTest.pl '8' '22'`

" # # In which "${SS_SCRIPT}/Statistics/SignTest.pl" is an executable script, # This line will end up printed as: # "p <= 0.0161

" # # Note that the META tag itself will never be printed, and is invisible to # the outside world. # # The SRC files in a DIV or INS tag will be added (pre-pended) to the body # of the

tag. Blocks are NOT executed! If you do not # need any content, you can use the format. # # # THE CGISCRIPTOR ROOT DIRECTORIES ~/ AND ./ # # Inside tags, filepaths starting # with "~/" are replaced by "$YOUR_HTML_FILES/", this way files in the # public directories can be accessed without direct reference to the # actual paths. Filepaths starting with "./" are replaced by # "$YOUR_SCRIPTS/" and this should only be used for scripts. # # Note: this replacement can seriously affect Perl scripts. Watch # out for constructs like $a =~ s/aap\./noot./g, use # $a =~ s@aap\.@noot.@g instead. # # CGIscriptor.pl will assign the values of $SS_PUB and $SS_SCRIPT # (i.e., $YOUR_HTML_FILES and $YOUR_SCRIPTS) to the environment variables # $SS_PUB and $SS_SCRIPT. These can be accessed by the scripts that are # executed. # Values not preceded by $, ~/, or ./ are used as literals # # # OS SHELL SCRIPT EVALUATION (CONTENT-TYPE=TEXT/OSSHELL) # # OS scripts are executed by a "safe" version of the `` operator (i.e., # SAFEqx(), see also below) and any output is printed. CGIscriptor will # interpolate the script and replace all user-supplied CGI-variables by # their ''-quoted values (actually, all variables defined in CGI attributes # are quoted). Other Perl variables are interpolated in a simple fasion, # i.e., $scalar by their value, @list by join(' ', @list), and %hash by # their name=value pairs. Complex references, e.g., @$variable, are all # evaluated in a scalar context. Quotes should be used with care. # NOTE: the results of the shell script evaluation will appear in the # @CGIscriptorResults stack just as any other result. # All occurrences of $@% that should NOT be interpolated must be # preceeded by a "\". Interpolation can be switched off completely by # setting $CGIscriptor::NoShellScriptInterpolation = 1 # (set to 0 or undef to switch interpolation on again) # i.e., # # # # RUN TIME TRANSLATION OF INPUT FILES # # Allows general and global conversions of files using Regular Expressions. # Very handy (but costly) to rewrite legacy pages to a new format. # Select files to use it on with # my $TranslationPaths = 'filepattern'; # This is costly. For efficiency, define: # $TranslationPaths = ''; when not using translations. # Accepts general regular expressions: [$pattern, $replacement] # # Define: # my $TranslationPaths = 'filepattern'; # Pattern matching PATH_INFO # # push(@TranslationTable, ['pattern', 'replacement']); # e.g. (for Ruby Rails): # push(@TranslationTable, ['<%=', '']); # # Runs: # my $currentRegExp; # foreach $currentRegExp (@TranslationTable) # { # my ($pattern, $replacement) = @$currentRegExp; # $$text =~ s!$pattern!$replacement!msg; # }; # # # EVALUATION OF OTHER SCRIPTING LANGUAGES # # Adding a MIME-type and an interpreter command to # %ScriptingLanguages automatically will catch any other # scripting language in the standard # manner. # E.g., adding: $ScriptingLanguages{'text/sspython'} = 'python'; # will actually execute the folowing code in an HTML page # (ignore 'REMOTE_HOST' for the moment): # # # The script code is NOT interpolated by perl, EXCEPT for those # interpreters that cannot handle variables themselves. # Currently, several interpreters are pre-installed: # # Perl test - "text/testperl" => 'perl', # Python - "text/sspython" => 'python', # Ruby - "text/ssruby" => 'ruby', # Tcl - "text/sstcl" => 'tcl', # Awk - "text/ssawk" => 'awk -f-', # Gnu Lisp - "text/sslisp" => 'rep | tail +5 '. # "| egrep -v '> |^rep. |^nil\\\$'", # XLispstat - "text/xlispstat" => 'xlispstat | tail +7 '. # "| egrep -v '> \\\$|^NIL'", # Gnu Prolog- "text/ssprolog" => 'gprolog', # M4 macro's- "text/ssm4" => 'm4', # Born shell- "text/sh" => 'sh', # Bash - "text/bash" => 'bash', # C-shell - "text/csh" => 'csh', # Korn shell- "text/ksh" => 'ksh', # Praat - "text/sspraat" => "praat - | sed 's/Praat > //g'", # R - "text/ssr" => "R --vanilla --slave | sed 's/^[\[0-9\]*] //g'", # REBOL - "text/ssrebol" => # "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\s*\[> \]* //g'", # PostgreSQL- "text/postgresql" => 'psql 2>/dev/null', # (psql) # # Note that the "value" of $ScriptingLanguages{mime} must be a command # that reads Standard Input and writes to standard output. Any extra # output of interactive interpreters (banners, echo's, prompts) # should be removed by piping the output through 'tail', 'grep', # 'sed', or even 'awk' or 'perl'. # # For access to CGI variables there is a special hashtable: # %ScriptingCGIvariables. # CGI variables can be accessed in three ways. # 1. If the mime type is not present in %ScriptingCGIvariables, # nothing is done and the script itself should parse the relevant # environment variables. # 2. If the mime type IS present in %ScriptingCGIvariables, but it's # value is empty, e.g., $ScriptingCGIvariables{"text/sspraat"} = '';, # the script text is interpolated by perl. That is, all $var, @array, # %hash, and \-slashes are replaced by their respective values. # 3. In all other cases, the CGI and environment variables are added # in front of the script according to the format stored in # %ScriptingCGIvariables. That is, the following (pseudo-)code is # executed for each CGI- or Environment variable defined in the CGI-tag: # printf(INTERPRETER, $ScriptingCGIvariables{$mime}, $CGI_NAME, $CGI_VALUE); # # For instance, "text/testperl" => '$%s = "%s";' defines variable # definitions for Perl, and "text/sspython" => '%s = "%s"' for Python # (note that these definitions are not save, the real ones contain '-quotes). # # THIS WILL NOT WORK FOR @VARIABLES, the (empty) $VARIABLES will be used # instead. # # The $CGI_VALUE parameters are "shrubed" of all control characters # and quotes (by &shrubCGIparameter($CGI_VALUE)) for the options 2 and 3. # Control characters are replaced by \0 (the exception # is \015, the newline, which is replaced by \n) and quotes # and backslashes by their HTML character # value (' -> ' ` -> ` " -> " \ -> \ & -> &er;). # For example: # if a client would supply the string value (in standard perl, e.g., # \n means ) # "/dev/null';\nrm -rf *;\necho '" # it would be processed as # '/dev/null';\nrm -rf *;\necho '' # (e.g., sh or bash would process the latter more according to your # intentions). # If your intepreter requires different protection measures, you will # have to supply these in %main::SHRUBcharacterTR (string => translation), # e.g., $SHRUBcharacterTR{"\'"} = "'"; # # Currently, the following definitions are used: # %ScriptingCGIvariables = ( # "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value' (for testing) # "text/sspython" => "\%s = '\%s'", # Python VAR = 'value' # "text/ssruby" => '@%s = "%s"', # Ruby @VAR = "value" # "text/sstcl" => 'set %s "%s"', # TCL set VAR "value" # "text/ssawk" => '%s = "%s";', # Awk VAR = "value"; # "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value") # "text/xlispstat" => '(setq %s "%s")', # Xlispstat (setq VAR "value") # "text/ssprolog" => '', # Gnu prolog (interpolated) # "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value') # "text/sh" => "\%s='\%s';", # Born shell VAR='value'; # "text/bash" => "\%s='\%s';", # Born again shell VAR='value'; # "text/csh" => "\$\%s = '\%s';", # C shell $VAR = 'value'; # "text/ksh" => "\$\%s = '\%s';", # Korn shell $VAR = 'value'; # "text/sspraat" => '', # Praat (interpolation) # "text/ssr" => '%s <- "%s";', # R VAR <- "value"; # "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value" # "text/postgresql" => '', # PostgreSQL (interpolation) # "" => "" # ); # # Four tables allow fine-tuning of interpreter with code that should be # added before and after each code block: # # Code added before each script block # %ScriptingPrefix = ( # "text/testperl" => "\# Prefix Code;", # Perl script testing # "text/ssm4" => 'divert(0)' # M4 macro's (open STDOUT) # ); # Code added at the end of each script block # %ScriptingPostfix = ( # "text/testperl" => "\# Postfix Code;", # Perl script testing # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT) # ); # Initialization code, inserted directly after opening (NEVER interpolated) # %ScriptingInitialization = ( # "text/testperl" => "\# Initialization Code;", # Perl script testing # "text/ssawk" => 'BEGIN {', # Server Side awk scripts # "text/sslisp" => '(prog1 nil ', # Lisp (rep) # "text/xlispstat" => '(prog1 nil ', # xlispstat # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT) # ); # Cleanup code, inserted before closing (NEVER interpolated) # %ScriptingCleanup = ( # "text/testperl" => "\# Cleanup Code;", # Perl script testing # "text/sspraat" => 'Quit', # "text/ssawk" => '};', # Server Side awk scripts # "text/sslisp" => '(princ "\n" standard-output)).' # Closing print to rep # "text/xlispstat" => '(print "" *standard-output*)).' # Closing print to xlispstat # "text/postgresql" => '\q', # ); # # # The SRC attribute is NOT magical for these interpreters. In short, # all code inside a source file or {} block is written verbattim # to the interpreter. No (pre-)processing or executional magic is done. # # A serious shortcomming of the described mechanism for handling other # (scripting) languages, with respect to standard perl scripts # (i.e., 'text/ssperl'), is that the code is only executed when # the pipe to the interpreter is closed. So the pipe has to be # closed at the end of each block. This means that the state of the # interpreter (e.g., all variable values) is lost after the closing of # the next tag. The standard 'text/ssperl' scripts retain # all values and definitions. # # APPLICATION MIME TYPES # # To ease some important auxilliary functions from within the # html pages I have added them as MIME types. This uses # the mechanism that is also used for the evaluation of # other scripting languages, with interpolation of CGI # parameters (and perl-variables). Actually, these are # defined exactly like any other "scripting language". # # text/ssdisplay: display some (HTML) text with interpolated # variables (uses `cat`). # text/sslogfile: write (append) the interpolated block to the file # mentioned on the first, non-empty line # (the filename can be preceded by 'File: ', # note the space after the ':', # uses `awk .... >> `). # text/ssmailto: send email directly from within the script block. # The first line of the body must contain # To:Name@Valid.Email.Address # (note: NO space between 'To:' and the email adres) # For other options see the mailto man pages. # It works by directly sending the (interpolated) # content of the text block to a pipe into the # Linux program 'mailto'. # # In these script blocks, all Perl variables will be # replaced by their values. All CGI variables are cleaned before # they are used. These CGI variables must be redefined with a # CGI attribute to restore their original values. # In general, this will be more secure than constructing # e.g., your own email command lines. For instance, Mailto will # not execute any odd (forged) email addres, but just stops # when the email address is invalid and awk will construct # any filename you give it (e.g. ' \n" # line, the rest of the shell script is piped into the indicated command, # i.e., # open(COMMAND, "| command");print COMMAND $RestOfScript; # # In many ways this is equivalent to the MIME-type profiling for # evaluating other scripting languages as discussed above. The # difference breaks down to convenience. Shell script piping is a # "raw" implementation. It allows you to control all aspects of # execution. Using the MIME-type profiling is easier, but has a # lot of defaults built in that might get in the way. Another # difference is that shell script piping uses the SAFEqx() function, # and MIME-type profiling does not. # # Execution of shell scripts is under the control of the Perl Script blocks # in the document. The MIME-type triggered execution of # blocks can be simulated easily. You can switch to a different shell, # e.g. tcl, completely by executing the following Perl commands inside # your document: # # # # After this script is executed, CGIscriptor will parse scripts of # TYPE="text/ssTcl" and pipe their contents into '|/usr/bin/tcl' # WITHOUT interpolation (i.e., NO substitution of Perl variables). # The crucial function is : # CGIscriptor::RedirectShellScript('/usr/bin/tcl') # After executing this function, all shell scripts AND all # calls to SAFEqx()) are piped into '|/usr/bin/tcl'. If the argument # of RedirectShellScript is empty, e.g., '', the original (default) # value is reset. # # The standard output, STDOUT, of any pipe is send to the client. # Currently, you should be carefull with quotes in such a piped script. # The results of a pipe is NOT put on the @CGIscriptorResults stack. # As a result, you do not have access to the output of any piped (#!) # process! If you want such access, execute # # or # . # # Safety is never complete. Although SAFEqx() prevents some of the # most obvious forms of attacks and security slips, it cannot prevent # them all. Especially, complex combinations of quotes and intricate # variable references cannot be handled safely by SAFEqx. So be on # guard. # # # PERL CODE EVALUATION (CONTENT-TYPE=TEXT/SSPERL) # # All PERL scripts are evaluated inside a PERL package. This package # has a separate name space. This isolated name space protects the # CGIscriptor.pl program against interference from user code. However, # some variables, e.g., $_, are global and cannot be protected. You are # advised NOT to use such global variable names. You CAN write # directives that directly access the variables in the main program. # You do so at your own risk (there is definitely enough rope available # to hang yourself). The behavior of CGIscriptor becomes undefined if # you change its private variables during run time. The PERL code # directives are used as in: # $Result = eval($directive); print $Result;''; # ($directive contains all text between ). # That is, the is treated as ''-quoted string and # the result is treated as a scalar. To prevent the VALUE of the code # block from appearing on the client's screen, end the directive with # ';""'. Evaluated directives return the last value, just as # eval(), blocks, and subroutines, but only as a scalar. # # IMPORTANT: All PERL variables defined are persistent. Each construct is evaluated as a {}-block with associated scope # (e.g., for "my $var;" declarations). This means that values assigned # to a PERL variable can be used throughout the document unless they # were declared with "my". The following will actually work as intended # (note that the ``-quotes in this example are NOT evaluated, but used # as simple quotes): # # # anything ... # # anything ... # # # The first construct will return the # value scalar(@List), the second # construct will print the elements of $String separated by commas, leaving # out the first element, i.e., $List[0]. # # Another warning: './' and '~/' are ALWAYS replaced by the values of # $YOUR_SCRIPTS and $YOUR_HTML_FILES, respectively . This can interfere # with pattern matching, e.g., $a =~ s/aap\./noot\./g will result in the # evaluations of $a =~ s/aap\\${YOUR_SCRIPTS}noot\\${YOUR_SCRIPTS}g. Use # s@.@.@g instead. # # # SERVER SIDE SESSIONS AND ACCESS CONTROL (LOGIN) # # An infrastructure for user acount authorization and file access control # is available. Each request is matched against a list of URL path patterns. # If the request matches, a Session Ticket is required to access the URL. # This Session Ticket should be present as a CGI parameter or Cookie, eg: # # CGI: SESSIONTICKET=<value> # Cookie: CGIscriptorSESSION=<value> # # The example implementation stores Session Tickets as files in a local # directory. To create Session Tickets, a Login request must be given # with a LOGIN=<value> CGI parameter, a user name and a (doubly hashed) # password. The user name and (singly hashed) password are stored in a # PASSWORD ticket with the same name as the user account (name cleaned up # for security). # # The example session model implements 4 functions: # - Login # The password is hashed with the user name and server side salt, and then # hashed with the REMOTE_HOST and a random salt. Client and Server both # perform these actions and the Server only grants access if restults are # the same. The server side only stores the password hashed with the user # name and server side salt. Neither the plain password, nor the hashed # password is ever exchanged. Only values hashed with the one-time salt # are exchanged. # - Session # For every access to a restricted URL, the Session Ticket is checked before # access is granted. There are three session modes. The first uses a fixed # Session Ticket that is stored as a cookie value in the browser (actually, # as a sessionStorage value). The second uses only the IP address at login # to authenticate requests. The third # is a Challenge mode, where the client has to calculate the value of the # next one-time Session Ticket from a value derived from the password and # a random string. # - Password Change # A new password is hashed with the user name and server side salt, and # then encrypted (XORed) # with the old password hashed with the user name and salt. That value is # exchanged and XORed with the stored old hashed(password+username+salt). # Again, the stored password value is never exchanged unencrypted. # - New Account # The text of a new account (Type: PASSWORD) file is constructed from # the new username (CGI: NEWUSERNAME, converted to lowercase) and # hashed new password (CGI: NEWPASSWORD). The same process is used to encrypt # the new password as is used for the Password Change function. # Again, the stored password value is never exchanged unencrypted. # Some default setting are encoded. For display in the browser, the new password # is reencrypted (XORed) with a special key, the old password hash # hashed with a session specific random hex value sent initially with the # session login ticket ($RANDOMSALT). # For example for user "NewUser" and password "NewPassword" with filename # "newuser": # # Type: PASSWORD # Username: newuser # Password: 19afeadfba8d5dcd252e157fafd3010859f8762b87682b6b6cdb3e565194fa91 # IPaddress: 127\.0\.0\.1 # AllowedPaths: ^/Private/[\w\-]+\.html? # AllowedPaths: ^/Private/newuser/ # Salt: e93cf858a1d5626bf095ea5c25df990dfa969ff5a5dc908b22c9a5229b525f65 # Session: SESSION # Date: Fri Jun 29 12:46:22 2012 # Time: 1340973982 # Signature: 676c35d3aa63540293ea5442f12872bfb0a22665b504f58f804582493b6ef04e # # The password is created with the commands: # # printf '%s' 'NewPasswordnewuser970e68017413fb0ea84d7fe3c463077636dd6d53486910d4a53c693dd4109b1a'|shasum -a 256 # # If the CPAN mudule Digest is installed, it is used instead of the commands. # However, the password account files are protected against unauthorized change. # To obtain a valid Password account, the following command should be given: # # perl CGIscriptor.pl --managelogin salt=Private/.Passwords/SALT \ # masterkey='Sherlock investigates oleander curry in Bath' \ # password='NewPassword' \ # Private/.Passwords/newuser # # # Implementation # # The session authentication mechanism is based on the exchange of ticket # identifiers. A ticket identifier is just a string of characters, a name # or a random 64 character hexadecimal string. Authentication is based # on a (password derived) shared secret and the ability to calculate ticket # identifiers from this shared secret. Ticket identifiers should be # "safe" filenames (except user names). There are four types of tickets: # PASSWORD: User account descriptors, including a user name and password # LOGIN: Temporary anonymous tickets used during login # IPADDRESS: Authentication tokens that allow access based on the IP address of the request # SESSION: Reusable authentication tokens # CHALLENGE: One-time authentication tokens # All tickets can have an expiration date in the form of a time duration # from creation, in seconds, minutes, hours, or days (+duration[smhd]). # An absolute time can be given in seconds since the epoch of the server host. # Note that expiration times of CHALLENGE authentication tokens are calculated # from the last access time. Accounts can include a maximal lifetime # for session tickets (MaxLifetime). # # A Login page should create a LOGIN ticket file locally and send a # server specific salt, a Random salt, and a LOGIN ticket # identifier. The server side compares the username and hashed password, # actually hashed(hashed(password+serversalt)+Random salt) from the client with # the values it calculates from the stored Random salt from the LOGIN # ticket and the hashed(password+serversalt) from the PASSWORD ticket. If # successful, a new SESSION ticket is generated as a (double) hash sum of the stored # password and the LOGIN ticket, i.e. # LoginTicket = hashed(hashed(password+serversalt)+REMOTE_HOST + Random salt) and # SessionTicket = hashed(hashed(LoginTicket).LoginTicket). This SESSION # ticket should also be generated by the client and stored as # sessionStorage and cookie values as needed. The Username, IP address # and Path are available as $LoginUsername, $LoginIPaddress, and # $LoginPath, respectively. # # The CHALLENGE protocol stores the single hashed version of the SESSION tickets. # However, this value is not exchanged, but kept secret in the JavaScript # sessionStorage object. Instead, every page returned from the # server will contain a one-time Challenge value ($CHALLENGETICKET) which # has to be hashed with the stored value to return the current ticket # id string. # # In the current example implementation, all random values are created as # full, 256 bit SHA256 hash values (Hex strings) of 64 bytes read from # /dev/urandom. # # # Authorization # # A limited level of authorization tuning is build into the login system. # Each account file (PASSWORD ticket file) can contain a number of # Capabilities lines. These control special priveliges. The # Capabilities can be checked inside the HTML pages as part of the # ticket information. Two privileges are handled internally: # CreateUser and VariableREMOTE_ADDR. # CreateUser allows the logged in user to create a new user account. # With VariableREMOTE_ADDR, the session of the logged in user is # not limited to the Remote IP address from which the inital log-in took # place. Sessions can hop from one apparant (proxy) IP address to another, # e.g., when using Tor. Any IPaddress patterns given in the PASSWORD # ticket file remain in effect during the session. For security reasons, # the VariableREMOTE_ADDR capability is only effective if the session # type is CHALLENGE. # # # Security considerations with Session tickets # # For strong security, please use end-to-end encryption. This can be # achieved using a VPN (Virtual Private Network), SSH tunnel, or a HTTPS # capable server with OpenSSL. The session ticket system of CGIscriptor.pl # is intended to be used as a simple authentication mechanism WITHOUT # END-TO-END ENCRYPTION. The authenticating mechanism tries to use some # simple means to protect the authentication process from eavesdropping. # For this it uses a secure hash function, SHA256. For all practial purposes, # it is impossible to "decrypt" a SHA256 sum. But this login scheme is # only as secure as your browser. Which, in general, is not very secure. # # One fundamental weakness of the implemented procedure is that the Client # obtains the code to encrypt the passwords from the server. It is the JavaScript # code in the HTML pages. An attacker who could place himself between Server # and Client, a man in the middle attack (MITM), could change the code to # reveal the plaintext password and other information. There is no # real protection against this attack without end-to-end encryption and # authentication. A simple, but rather cumbersome, way to check for such # attacks would be to store known good copys of the pages (downloaded # with a browser or automatically with curl or wget) and # then use other tools to download new pages at random intervals and compare # them to the old pages. For instance, the following line would remove # the variable ticket codes and give a fixed SHA256 sum for the original # Login.html page+code: # curl http://localhost:8080/Private/index.html | \ # sed 's/=\"[a-z0-9]\{64\}\"/=""/g' | shasum -a 256 # A simple diff command between old and new files should give only # differences in half a dozen lines, where only hexadecimal salt values # will actually differ. # # A sort of solution for the MITM attack problem that might protect at # least the plaintext password would be to run a trusted web # page from local storage to handle password input. The solution would be # to add a hidden iFrame tag loading the untrusted page from the URL and # extract the needed ticket and salt values. Then run the stored, trusted, # code with these values. It is not (yet) possible to set the # required session storage inside the browser, so this method only works # for IPADDRESS sessions and plain SESSION tickets. There are many # security problems with this "solution". # # If you are able to ascertain the integrity of the login page using any # of the above methods, you can check whether the IP address seen by the # login server is indeed the IP address of your computer. The IP address # of the REMOTE_HOST (your visible IP address) is part of the login # "password". It is stored in the login page as a CLIENTIPADDRESS. It can # can be inspected by clicking the "Check IP address" box. Provided the # MitM attacker cannot spoof your IP address, you can ensure that the login # server sees your IP address and not that of an attacker. # # Humans tend to reuse passwords. A compromise of a site running # CGIscriptor.pl could therefore lead to a compromise of user accounts at # other sites. Therefore, plain text passwords are never stored, used, or # exchanged. Instead, the plain password and user name are "encrypted" with # a server site salt value. Actually, all are concatenated and hashed # with a one-way secure hash function (SHA256) into a single string. # Whenever the word "password" is used, this hash sum is meant. Note that # the salts are generated from /dev/urandom. You should check whether the # implementation of /dev/urandom on your platform is secure before # relying on it. This might be a problem when running CGIscriptor under # Cygwin on MS Windows. # Note: no attempt is made to slow down the password hash, so bad # passwords can be cracked by brute force # # As the (hashed) passwords are all that is needed to identify at the site, # these should not be stored in this form. A site specific passphrase # can be entered as an environment variable ($ENV{'CGIMasterKey'}). This # phrase is hashed with the server site salt and the result is hashed with # the user name and then XORed with the password when it is stored. Also, to # detect changes to the account (PASSWORD) and session tickets, a # (HMAC) hash of some of the contents of the ticket with the server salt and # CGIMasterKey is stored in each ticket. # # Creating a valid (hashed) password, encrypt it with the CGIMasterKey and # construct a signature of the ticket are non-trivial. This has to be redone # with every change of the ticket file or CGIMasterKey change. CGIscriptor # can do this from the command line with the command: # # perl CGIscriptor.pl --managelogin salt=Private/.Passwords/SALT \ # masterkey='Sherlock investigates oleander curry in Bath' \ # password='There is no password like more password' \ # admin # # CGIscriptor will exit after this command with the first option being # --managelogin. Options have the form: # # salt=[file or string] # Server salt value to use io the value # stored in the ticket file. Will replace the stored value if a new # password is given. If you change the server salt, you have to # reset all the passwords. There is absolutely no procedure known # to recover plaintext passwords, except asking the account holders. # You are strongly adviced to make a backup before you apply such a change # masterkey=[file or string] # CGIMasterKey used to read and decrypt the ticket # newmasterkey=[file or string] # CGIMasterKey used to encrypt, sign, # and write the ticket. Defaults to the masterkey. If you change # the masterkey, you will have to reset all the accounts. You are strongly # adviced to make a backup before you apply such a change # password=[file or string] # New plaintext password # # When the value of an option is a existing file path, the first line of # that file is used. Options are followed by one or more paths plus names # of existing ticket files. Each password option is only used for a single # ticket file. It is most definitely a bad idea to use a password that is # identical to an existing filepath, as the file will be read instead. Be # aware that the name of the file should be a cleaned up version of the # Username. This will not be checked. # # For the authentication and a change of password, the (old) password # is used to "encrypt" a random one-time token or the new password, # respectively. For authentication, decryption is not needed, so a secure # hash function (SHA256) is used to create a one-way hash sum "encryption". # A new password must be decrypted. New passwords are encryped by XORing # them with the old password. # # Strong Passwords: It is so easy # If you only could see what you are typing # # Your password might be vulnerable to brute force guessing # (https://en.wikipedia.org/wiki/Brute_force_attack). # Protections against such attacks are costly in terms of code # complexity, bugs, and execution time. However, there is a very # simple and secure counter measure. See the XKCD comic # (http://xkcd.com/936/). The phrase, "There is no password like more # password" would be both much easier to remember, and still stronger # than "h4]D%@m:49", at least before this phrase was pasted as an # example on the Internet. # # For the procedures used at this site, a basic computer setup can # check in the order of a billion passwords per second. You need a # password (or phrase) strength in the order of 56 bits to be a # little secure (one year on a single computer). Please be so kind # and add the name of your favorite flower, dish, fictional # character, or small town to your password. Say, Oleander, Curry, # Sherlock, or Bath, UK (each adds ~12 bits) or even the phrase "Sherlock # investigates oleander curry in Bath" (adds > 56 bits, note that # oleander is poisonous, so do not try this curry at home). That # would be more effective than adding a thousand rounds of encryption. # Typing long passwords without seeing what you are typing is # problematic. So a button should be included to make password # visible. # # # Technical matters # # Client side JavaScript code definitions. Variable names starting with '$' # are CGIscriptor CGI variables. Some of the hashes could be strengthened # by switching to HMAC signatures. However, the security issues of # maintaining parallel functions for HMAC in both Perl and Javascript seem # to be more serious than the attack vectors against the hashes. But HMAC # is indeed used for the ticket signatures. # # // On Login # HashPlaintextPassword() { # var plaintextpassword = document.getElementById('PASSWORD'); # var serversalt = document.getElementById('SERVERSALT'); # var username = document.getElementById('CGIUSERNAME'); # return hex_sha256(plaintextpassword.value+username.value.toLowerCase()+serversalt.value); # } # var randomsalt = $RANDOMSALT; // From CGIscriptor # var loginticket = $LOGINTICKET; // From CGIscriptor # // Hash plaintext password # var password = HashPlaintextPassword(); # // Authorize login # var hashedpassword = hex_sha256(randomsalt+password); # // Sessionticket # var sessionticket = hex_sha256(loginticket+password); # sessionStorage.setItem("CGIscriptorPRIVATE", sessionticket); # // Secretkey for encrypting new passwords, acts like a one-time pad # // Is set anew with every login, ie, also whith password changes # // and for each create new user request # var secretkey = hex_sha256(password+loginticket+randomsalt); # sessionStorage.setItem("CGIscriptorSECRET", secretkey); # # // For a SESSION type request # sessionticket = hex_sha256(sessionStorage.getItem("CGIscriptorPRIVATE")); # createCookie("CGIscriptorSESSION",sessionticket, 0, ""); # // For a CHALLENGE type request # var sessionset = "$CHALLENGETICKET"; // From CGIscriptor # var sessionkey = sessionStorage.getItem("CGIscriptorPRIVATE"); # sessionticket = hex_sha256(sessionset+sessionkey); # createCookie("CGIscriptorCHALLENGE",sessionticket, 0, ""); # # // For transmitting a new password # HashPlaintextNewPassword() { # var plaintextpassword = document.getElementById('NEWPASSWORD'); # var serversalt = document.getElementById('SERVERSALT'); # var username = document.getElementById('NEWUSERNAME'); # return hex_sha256(plaintextpassword.value+username.value.toLowerCase()+serversalt.value); # } # # var newpassword = document.getElementById('NEWPASSWORD'); # var newpasswordrep = document.getElementById('NEWPASSWORDREP'); # // Hash plaintext password # newpassword.value = HashPlaintextNewPassword(); # var secretkey = sessionStorage.getItem("CGIscriptorSECRET"); # # var encrypted = XOR_hex_strings(secretkey, newpassword.value); # newpassword.value = encrypted; # newpasswordrep.value = encrypted; # # // XOR of hexadecimal strings of equal length # function XOR_hex_strings(hex1, hex2) { # var resultHex = ""; # var maxlength = Math.max(hex1.length, hex2.length); # # for(var i=0; i < maxlength; ++i) { # var h1 = hex1.charAt(i); # if(! h1) h1='0'; # var h2 = hex2.charAt(i); # if(! h2) h2 ='0'; # var d1 = parseInt(h1,16); # var d2 = parseInt(h2,16); # var resultD = d1^d2; # resultHex = resultHex+resultD.toString(16); # }; # return resultHex; # }; # # Password encryption based on $ENV{'CGIMasterKey'}. # Server side Perl code: # # # Password encryption # my $masterkey = $ENV{'CGIMasterKey'} # my $hash1 = hash_string($masterkey.$serversalt); # my $CryptKey = hash_string($username.$hash1); # $password = XOR_hex_strings($CryptKey,$password); # # # Key for HMAC signing # my $hash1 = hash_string($masterkey.$serversalt); # my $HMACKey = hash_string($username.$hash1); # # # # USER EXTENSIONS # # A CGIscriptor package is attached to the bottom of this file. With # this package you can personalize your version of CGIscriptor by # including often used perl routines. These subroutines can be # accessed by prefixing their names with CGIscriptor::, e.g., # # It already contains some useful subroutines for Document Management. # As it is a separate package, it has its own namespace, isolated from # both the evaluator and the main program. To access variables from # the document blocks, use $CGIexecute::. # # Currently, the following functions are implemented # (precede them with CGIscriptor::, see below for more information) # - SAFEqx ('String') -> result of qx/"String"/ # Safe application of ``-quotes # Is used by text/osshell Shell scripts. Protects all CGI # (client-supplied) values with single quotes before executing the # commands (one of the few functions that also works WITHOUT CGIscriptor:: # in front) # - defineCGIvariable ($name[, $default) -> 0/1 (i.e., failure/success) # Is used by the META tag to define and initialize CGI and ENV # name/value pairs. Tries to obtain an initializing value from (in order): # $ENV{$name} # The Query string # The default value given (if any) # (one of the few functions that also works WITHOUT CGIscriptor:: # in front) # - CGIsafeFileName (FileName) -> FileName or "" # Check a string against the Allowed File Characters (and ../ /..). # Returns an empty string for unsafe filenames. # - CGIsafeEmailAddress (Email) -> Email or "" # Check a string against correct email address pattern. # Returns an empty string for unsafe addresses. # - RedirectShellScript ('CommandString') -> FILEHANDLER or undef # Open a named PIPE for SAFEqx to receive ALL shell scripts # - URLdecode (URL encoded string) -> plain string # Decode URL encoded argument # - URLencode (plain string) -> URL encoded string # Encode argument as URL code # - CGIparseValue (ValueName [, URL_encoded_QueryString]) -> Decoded value # Extract the value of a CGI variable from the global or a private # URL-encoded query (multipart POST raw, NOT decoded) # - CGIparseValueList (ValueName [, URL_encoded_QueryString]) # -> List of decoded values # As CGIparseValue, but now assembles ALL values of ValueName into a list. # - CGIparseHeader (ValueName [, URL_encoded_QueryString]) -> Header # Extract the header of a multipart CGI variable from the global or a private # URL-encoded query ("" when not a multipart variable or absent) # - CGIparseForm ([URL_encoded_QueryString]) -> Decoded Form # Decode the complete global URL-encoded query or a private # URL-encoded query # - read_url(URL) # Returns the page from URL (with added base tag, both FTP and HTTP) # Uses main::GET_URL(URL, 1) to get at the command to read the URL. # - BrowseDirs(RootDirectory [, Pattern, Startdir, CGIname]) # print browsable directories # - ListDocs(Pattern [,ListType]) # Prints a nested HTML directory listing of # all documents, e.g., ListDocs("/*", "dl");. # - HTMLdocTree(Pattern [,ListType]) # Prints a nested HTML listing of all # local links starting from a given document, e.g., # HTMLdocTree("/Welcome.html", "dl"); # # # THE RESULTS STACK: @CGISCRIPTORRESULTS # # If the pseudo-variable "$CGIscriptorResults" has been defined in a # META tag, all subsequent SCRIPT and META results are pushed # on the @CGIscriptorResults stack. This list is just another # Perl variable and can be used and manipulated like any other list. # $CGIscriptorResults[-1] is always the last result. # This is only of limited use, e.g., to use the results of an OS shell # script inside a Perl script. Will NOT contain the results of Pipes # or code from MIME-profiling. # # # USEFULL CGI PREDEFINED VARIABLES (DO NOT ASSIGN TO THESE) # # $CGI_HOME - The DocumentRoot directory # $CGI_Decoded_QS - The complete decoded Query String # $CGI_Content_Length - The ACTUAL length of the Query String # $CGI_Date - Current date and time # $CGI_Year $CGI_Month $CGI_Day $CGI_WeekDay - Current Date # $CGI_Time - Current Time # $CGI_Hour $CGI_Minutes $CGI_Seconds - Current Time, split # GMT Date/Time: # $CGI_GMTYear $CGI_GMTMonth $CGI_GMTDay $CGI_GMTWeekDay $CGI_GMTYearDay # $CGI_GMTHour $CGI_GMTMinutes $CGI_GMTSeconds $CGI_GMTisdst # # # USEFULL CGI ENVIRONMENT VARIABLES # # Variables accessible (in APACHE) as $ENV{} # (see: "http://hoohoo.ncsa.uiuc.edu/cgi/env.html"): # # QUERY_STRING - The query part of URL, that is, everything that follows the # question mark. # PATH_INFO - Extra path information given after the script name # PATH_TRANSLATED - Extra pathinfo translated through the rule system. # (This doesn't always make sense.) # REMOTE_USER - If the server supports user authentication, and the script is # protected, this is the username they have authenticated as. # REMOTE_HOST - The hostname making the request. If the server does not have # this information, it should set REMOTE_ADDR and leave this unset # REMOTE_ADDR - The IP address of the remote host making the request. # REMOTE_IDENT - If the HTTP server supports RFC 931 identification, then this # variable will be set to the remote user name retrieved from # the server. Usage of this variable should be limited to logging # only. # AUTH_TYPE - If the server supports user authentication, and the script # is protected, this is the protocol-specific authentication # method used to validate the user. # CONTENT_TYPE - For queries which have attached information, such as HTTP # POST and PUT, this is the content type of the data. # CONTENT_LENGTH - The length of the said content as given by the client. # SERVER_SOFTWARE - The name and version of the information server software # answering the request (and running the gateway). # Format: name/version # SERVER_NAME - The server's hostname, DNS alias, or IP address as it # would appear in self-referencing URLs # GATEWAY_INTERFACE - The revision of the CGI specification to which this # server complies. Format: CGI/revision # SERVER_PROTOCOL - The name and revision of the information protocol this # request came in with. Format: protocol/revision # SERVER_PORT - The port number to which the request was sent. # REQUEST_METHOD - The method with which the request was made. For HTTP, # this is "GET", "HEAD", "POST", etc. # SCRIPT_NAME - A virtual path to the script being executed, used for # self-referencing URLs. # HTTP_ACCEPT - The MIME types which the client will accept, as given by # HTTP headers. Other protocols may need to get this # information from elsewhere. Each item in this list should # be separated by commas as per the HTTP spec. # Format: type/subtype, type/subtype # HTTP_USER_AGENT - The browser the client is using to send the request. # General format: software/version library/version. # # # INSTRUCTIONS FOR RUNNING CGIscriptor ON UNIX # # CGIscriptor.pl will run on any WWW server that runs Perl scripts, just add # a line like the following to your srm.conf file (Apache example): # # ScriptAlias /SHTML/ /real-path/CGIscriptor.pl/ # # URL's that refer to http://www.your.address/SHTML/... will now be handled # by CGIscriptor.pl, which can use a private directory tree (default is the # DOCUMENT_ROOT directory tree, but it can be anywhere, see manual). # # If your hosting ISP won't let you add ScriptAlias lines you can use # the following "rewrite"-based "scriptalias" in .htaccess # (from Gerd Franke) # # RewriteEngine On # RewriteBase / # RewriteCond %{REQUEST_FILENAME} .html$ # RewriteCond %{SCRIPT_FILENAME} !cgiscriptor.pl$ # RewriteCond %{REQUEST_FILENAME} -f # RewriteRule ^(.*)$ /cgi-bin/cgiscriptor.pl/$1?&%{QUERY_STRING} # # Everthing with the extension ".html" and not including "cgiscriptor.pl" # in the url and where the file "path/filename.html" exists is redirected # to "/cgi.bin/cgiscriptor.pl/path/filename.html?query". # The user configuration should get the same path-level as the # .htaccess-file: # # # Just enter your own directory path here # $YOUR_HTML_FILES = "$ENV{'DOCUMENT_ROOT'}"; # # use DOCUMENT_ROOT only, if .htaccess lies in the root-directory. # # If this .htaccess goes in a specific directory, the path to this # directory must be added to $ENV{'DOCUMENT_ROOT'}. # # The CGIscriptor file contains all documentation as comments. These # comments can be removed to speed up loading (e.g., `egrep -v '^#' # CGIscriptor.pl` > leanScriptor.pl). A bare bones version of # CGIscriptor.pl, lacking documentation, most comments, access control, # example functions etc. (but still with the copyright notice and some # minimal documentation) can be obtained by calling CGIscriptor.pl on the # command line with the '-slim' command line argument, e.g., # # >CGIscriptor.pl -slim > slimCGIscriptor.pl # # CGIscriptor.pl can be run from the command line with and as # arguments, as `CGIscriptor.pl `, inside a perl script # with 'do CGIscriptor.pl' after setting $ENV{PATH_INFO} # and $ENV{QUERY_STRING}, or CGIscriptor.pl can be loaded with 'require # "/real-path/CGIscriptor.pl"'. In the latter case, requests are processed # by 'Handle_Request();' (again after setting $ENV{PATH_INFO} and # $ENV{QUERY_STRING}). # # Using the command line execution option, CGIscriptor.pl can be used as a # document (meta-)preprocessor. If the first argument is '-', STDIN will be read. # For example: # # > cat MyDynamicDocument.html | CGIscriptor.pl - '[QueryString]' > MyStaticFile.html # # This command line will produce a STATIC file with the DYNAMIC content of # MyDocument.html "interpolated". # # This option would be very dangerous when available over the internet. # If someone could sneak a 'http://www.your.domain/-' URL past your # server, CGIscriptor could EXECUTE any POSTED contend. # Therefore, for security reasons, STDIN will NOT be read # if ANY of the HTTP server environment variables is set (e.g., # SERVER_PORT, SERVER_PROTOCOL, SERVER_NAME, SERVER_SOFTWARE, # HTTP_USER_AGENT, REMOTE_ADDR). # This block on processing STDIN on HTTP requests can be lifted by setting # $BLOCK_STDIN_HTTP_REQUEST = 0; # In the security configuration. Butbe carefull when doing this. # It can be very dangerous. # # Running demo's and more information can be found at # http://www.fon.hum.uva.nl/~rob/OSS/OSS.html # # A pocket-size HTTP daemon, CGIservlet.pl, is available from my web site or # CPAN that can use CGIscriptor.pl as the base of a µWWW server and # demonstrates its use. # # # PROCESSING NON-FILESYSTEM DATA # # Normally, HTTP (WWW) requests map onto file that can be accessed # using the perl open() function. That is, the web server runs on top of # some directory structure. However, we can envission (and put to good # use) other systems that do not use a normal file system. The whole CGI # was developed to make dynamic document generation possible. # # A special case is where we want to have it both: A normal web server # with normal "file data", but not a normal files system. For instance, # we want or normal Web Site to run directly from a RAM hash table or # other database, instead of from disk. But we do NOT want to code the # whole site structure in CGI. # # CGIscriptor can do this. If the web server fills an environment variable # $ENV{'CGI_FILE_CONTENT'} with the content of the "file", then the content # of this variable is processed instead of opening a file. If this environment # variable has the value '-', the content of another environment variable, # $ENV{'CGI_DATA_ACCESS_CODE'} is executed as: # eval("\@_ = ($file_path); do {$ENV{'CGI_DATA_ACCESS_CODE'}};") # and the result is processed as if it was the content of the requested # file. # (actually, the names of the environment variables are user configurable, # they are stored in the local variables $CGI_FILE_CONTENT and # $CGI_DATA_ACCESS_CODE) # # When using this mechanism, the SRC attribute mechanism will only partially work. # Only the "recursive" calls to CGIscriptor (the ProcessFile() function) # will work, the automagical execution of SRC files won't. (In this case, # the SRC attribute won't work either for other scripting languages) # # # NON-UNIX PLATFORMS # # CGIscriptor.pl was mainly developed and tested on UNIX. However, as I # coded part of the time on an Apple Macintosh under MacPerl, I made sure # CGIscriptor did run under MacPerl (with command line options). But only # as an independend script, not as part of a HTTP server. I have used it # under Apache in Windows XP. # ENDOFHELPTEXT exit; }; ############################################################################### # # SECURITY CONFIGURATION # # Special configurations related to SECURITY # (i.e., optional, see also environment variables below) # # LOGGING # Log Clients and the requested paths (Redundant when loging Queries) # $ClientLog = "./Client.log"; # (uncomment for use) # # Format: Localtime | REMOTE_USER REMOTE_IDENT REMOTE_HOST REMOTE_ADDRESS \ # PATH_INFO CONTENT_LENGTH (actually, the real query+post length) # # Log Clients and the queries, the CGIQUERYDECODE is required if you want # to log queries. If you log Queries, the loging of Clients is redundant # (note that queries can be quite long, so this might not be a good idea) # #$QueryLog = "./Query.log"; # (uncomment for use) # # ACCESS CONTROL # the Access files should contain Hostnames or IP addresses, # i.e. REMOTE_HOST or REMOTE_ADDR, each on a separate line # optionally followed by one ore more file patterns, e.g., "edu /DEMO". # Matching is done "domain first". For example ".edu" matches all # clients whose "name" ends in ".edu" or ".EDU". The file pattern # "/DEMO" matches all paths that contain the strings "/DEMO" or "/demo" # (both matchings are done case-insensitive). # The name special symbol "-" matches ALL clients who do not supply a # REMOTE_HOST name, "*" matches all clients. # Lines starting with '-e' are evaluated. A non-zero return value indicates # a match. You can use $REMOTE_HOST, $REMOTE_ADDR, and $PATH_INFO. These # lines are evaluated in the program's own name-space. So DO NOT assign to # variables. # # Accept the following users (remove comment # and adapt filename) $CGI_Accept = -s "$YOUR_SCRIPTS/ACCEPT.lis" ? "$YOUR_SCRIPTS/ACCEPT.lis" : ''; # (uncomment for use) # # Reject requests from the following users (remove comment # and # adapt filename, this is only of limited use) $CGI_Reject = -s "$YOUR_SCRIPTS/REJECT.lis" ? "$YOUR_SCRIPTS/REJECT.lis" : ''; # (uncomment for use) # # Empty lines or comment lines starting with '#' are ignored in both # $CGI_Accept and $CGI_Reject. # # Block STDIN (i.e., '-') requests when servicing an HTTP request # Comment this out if you realy want to use STDIN in an on-line web server $BLOCK_STDIN_HTTP_REQUEST = 1; # # # End of security configuration # ##################################################<<<<<<<<< 0, returns a list value, if $List < 0, a hash table, this is optional) sub YOUR_CGIPARSE # ($Name [, $List]) -> Decoded value { my $Name = shift; my $List = shift || 0; # Use one of the following by uncommenting if(!$List) # Simple value { return CGIscriptor::CGIparseValue($Name) ; } elsif($List < 0) # Hash tables { return CGIscriptor::CGIparseValueHash($Name); # Defined in CGIscriptor below } else # Lists { return CGIscriptor::CGIparseValueList($Name); # Defined in CGIscriptor below }; # return `/PATH/cgiparse -value $Name`; # Shell commands # require "/PATH/cgiparse.pl"; return cgivalue($Name); # Library } # Complete queries sub YOUR_CGIQUERYDECODE { # Use one of the following by uncommenting return CGIscriptor::CGIparseForm(); # Defined in CGIscriptor below # return `/PATH/cgiparse -form`; # Shell commands # require "/PATH/cgiparse.pl"; return cgiform(); # Library }; # # End of configuration # ####################################################################### # # Translating input files. # Allows general and global conversions of files using Regular Expressions # Translations are applied in the order of definition. # # Define: # my $TranslationPaths = 'pattern'; # Pattern matching PATH_INFO # # push(@TranslationTable, ['pattern', 'replacement']); # e.g. (for Ruby Rails): # push(@TranslationTable, ['<%=', '']); # # Runs: # my $currentRegExp; # foreach $currentRegExp (keys(%TranslationTable)) # { # my $currentRegExp; # foreach $currentRegExp (@TranslationTable) # { # my ($pattern, $replacement) = @$currentRegExp; # $$text =~ s!$pattern!$replacement!msg; # }; # }; # # Configuration section # ####################################################################### # # The file paths on which to apply the translation my $TranslationPaths = ''; # NO files #$TranslationPaths = '.'; # ANY file # $TranslationPaths = '\.html'; # HTML files my @TranslationTable = (); # Some legacy code push(@TranslationTable, ['\<\s*CGI\s+([^\>])*\>', '\']); sub performTranslation # (\$text) { my $text = shift || return; if(@TranslationTable && $TranslationPaths && $ENV{'PATH_INFO'} =~ m!$TranslationPaths!) { my $currentRegExp; foreach $currentRegExp (@TranslationTable) { my ($pattern, $replacement) = @$currentRegExp; $$text =~ s!$pattern!$replacement!msg; }; }; } # ####################################################################### # # Seamless access to other (Scripting) Languages # TYPE='text/ss' # # Configuration section # ####################################################################### # # OTHER SCRIPTING LANGUAGES AT THE SERVER SIDE (MIME => OScommand) # Yes, it realy is this simple! (unbelievable, isn't it) # NOTE: Some interpreters require some filtering to obtain "clean" output %ScriptingLanguages = ( "text/testperl" => 'perl', # Perl for testing "text/sspython" => 'python', # Python "text/ssruby" => 'ruby', # Ruby "text/sstcl" => 'tcl', # TCL "text/ssawk" => 'awk -f-', # Awk "text/sslisp" => # lisp (rep, GNU) 'rep | tail +4 '."| egrep -v '> |^rep. |^nil\\\$'", "text/xlispstat" => # xlispstat 'xlispstat | tail +7 ' ."| egrep -v '> \\\$|^NIL'", "text/ssprolog" => # Prolog (GNU) "gprolog | tail +4 | sed 's/^| ?- //'", "text/ssm4" => 'm4', # M4 macro's "text/sh" => 'sh', # Born shell "text/bash" => 'bash', # Born again shell "text/csh" => 'csh', # C shell "text/ksh" => 'ksh', # Korn shell "text/sspraat" => # Praat (sound/speech analysis) "praat - | sed 's/Praat > //g'", "text/ssr" => # R "R --vanilla --slave | sed 's/^[\[0-9\]*] //'", "text/ssrebol" => # REBOL "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\\s*\[> \]* //'", "text/postgresql" => 'psql 2>/dev/null', # Not real scripting, but the use of other applications "text/ssmailto" => "awk 'NF||F{F=1;print \\\$0;}'|mailto >/dev/null", # Send mail from server "text/ssdisplay" => 'cat', # Display, (interpolation) "text/sslogfile" => # Log to file, (interpolation) "awk 'NF||L {if(!L){L=tolower(\\\$1)~/^file:\\\$/ ? \\\$2 : \\\$1;}else{print \\\$0 >> L;};}'", "" => "" ); # # To be able to access the CGI variables in your script, they # should be passed to the scripting language in a readable form # Here you can enter how they should be printed (the first %s # is replaced by the NAME of the CGI variable as it apears in the # META tag, the second by its VALUE). # For Perl this would be: # "text/testperl" => '$%s = "%s";', # which would be executed as # printf('$%s = "%s";', $CGI_NAME, $CGI_VALUE); # # If the hash table value doesn't exist, nothing is done # (you have to parse the Environment variables yourself). # If it DOES exist but is empty (e.g., "text/sspraat" => '',) # Perl string interpolation of variables (i.e., $var, @array, # %hash) is performed. This means that $@%\ must be protected # with a \. # %ScriptingCGIvariables = ( "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value'; (for testing) "text/sspython" => "\%s = '\%s'", # Python VAR = 'value' "text/ssruby" => '@%s = "%s"', # Ruby @VAR = 'value' "text/sstcl" => 'set %s "%s"', # TCL set VAR "value" "text/ssawk" => '%s = "%s";', # Awk VAR = 'value'; "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value") "text/xlispstat" => '(setq %s "%s")', # xlispstat (setq VAR "value") "text/ssprolog" => '', # Gnu prolog (interpolated) "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value') "text/sh" => "\%s='\%s'", # Born shell VAR='value' "text/bash" => "\%s='\%s'", # Born again shell VAR='value' "text/csh" => "\$\%s='\%s';", # C shell $VAR = 'value'; "text/ksh" => "\$\%s='\%s';", # Korn shell $VAR = 'value'; "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value" "text/sspraat" => '', # Praat (interpolation) "text/ssr" => '%s <- "%s";', # R VAR <- "value"; "text/postgresql" => '', # PostgreSQL (interpolation) # Not real scripting, but the use of other applications "text/ssmailto" => '', # MAILTO, (interpolation) "text/ssdisplay" => '', # Display, (interpolation) "text/sslogfile" => '', # Log to file, (interpolation) "" => "" ); # If you want something added in front or at the back of each script # block as send to the interpreter add it here. # mime => "string", e.g., "text/sspython" => "python commands" %ScriptingPrefix = ( "text/testperl" => "\# Prefix Code;", # Perl script testing "text/ssm4" => 'divert(0)', # M4 macro's (open STDOUT) "" => "" ); # If you want something added at the end of each script block %ScriptingPostfix = ( "text/testperl" => "\# Postfix Code;", # Perl script testing "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT) "" => "" ); # If you need initialization code, directly after opening %ScriptingInitialization = ( "text/testperl" => "\# Initialization Code;", # Perl script testing "text/ssawk" => 'BEGIN {', # Server Side awk scripts (VAR = "value") "text/sslisp" => '(prog1 nil ', # Lisp (rep) "text/xlispstat" => '(prog1 nil ', # xlispstat "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT) "" => "" ); # If you need cleanup code before closing %ScriptingCleanup = ( "text/testperl" => "\# Cleanup Code;", # Perl script testing "text/sspraat" => 'Quit', "text/ssawk" => '};', # Server Side awk scripts (VAR = "value") "text/sslisp" => '(princ "\n" standard-output)).', # Closing print to rep "text/xlispstat" => '(print ""))', # Closing print to xlispstat "text/postgresql" => '\q', # quit psql "text/ssdisplay" => "", # close cat "" => "" ); # # End of configuration for foreign scripting languages # ############################################################################### # # Initialization Code # # sub Initialize_Request { ############################################################################### # # ENVIRONMENT VARIABLES # # Use environment variables to configure CGIscriptor on a temporary basis. # If you define any of the configurable variables as environment variables, # these are used instead of the "hard coded" values above. # $SS_PUB = $ENV{'SS_PUB'} || $YOUR_HTML_FILES; $SS_SCRIPT = $ENV{'SS_SCRIPT'} || $YOUR_SCRIPTS; # # Substitution strings, these are used internally to handle the # directory separator strings, e.g., '~/' -> 'SS_PUB:' (Mac) $HOME_SUB = $SS_PUB; $SCRIPT_SUB = $SS_SCRIPT; # # Make sure all script are reliably loaded push(@INC, $SS_SCRIPT); # Add the directory separator to the "home" directories. # (This is required for ~/ and ./ substitution) $HOME_SUB .= '/' if $HOME_SUB; $SCRIPT_SUB .= '/' if $SCRIPT_SUB; $CGI_HOME = $ENV{'DOCUMENT_ROOT'}; $ENV{'PATH_TRANSLATED'} =~ /$ENV{'PATH_INFO'}/is; $CGI_HOME = $` unless $ENV{'DOCUMENT_ROOT'}; # Get the DOCUMENT_ROOT directory $default_values{'CGI_HOME'} = $CGI_HOME; $ENV{'HOME'} = $CGI_HOME; # Set SS_PUB and SS_SCRIPT as Environment variables (make them available # to the scripts) $ENV{'SS_PUB'} = $SS_PUB unless $ENV{'SS_PUB'}; $ENV{'SS_SCRIPT'} = $SS_SCRIPT unless $ENV{'SS_SCRIPT'}; # $FilePattern = $ENV{'FilePattern'} || $FilePattern; $MaximumQuerySize = $ENV{'MaximumQuerySize'} || $MaximumQuerySize; $ClientLog = $ENV{'ClientLog'} || $ClientLog; $QueryLog = $ENV{'QueryLog'} || $QueryLog; $CGI_Accept = $ENV{'CGI_Accept'} || $CGI_Accept; $CGI_Reject = $ENV{'CGI_Reject'} || $CGI_Reject; # # Parse file names $CGI_Accept =~ s@^\~/@$HOME_SUB@g if $CGI_Accept; $CGI_Reject =~ s@^\~/@$HOME_SUB@g if $CGI_Reject; $ClientLog =~ s@^\~/@$HOME_SUB@g if $ClientLog; $QueryLog =~ s@^\~/@$HOME_SUB@g if $QueryLog; $CGI_Accept =~ s@^\./@$SCRIPT_SUB@g if $CGI_Accept; $CGI_Reject =~ s@^\./@$SCRIPT_SUB@g if $CGI_Reject; $ClientLog =~ s@^\./@$SCRIPT_SUB@g if $ClientLog; $QueryLog =~ s@^\./@$SCRIPT_SUB@g if $QueryLog; @CGIscriptorResults = (); # A stack of results # # end of Environment variables # ############################################################################# # # Define and Store "standard" values # # BEFORE doing ANYTHING check the size of Query String length($ENV{'QUERY_STRING'}) <= $MaximumQuerySize || dieHandler(2, "QUERY TOO LONG\n"); # # The Translated Query String and the Actual length of the (decoded) # Query String if($ENV{'QUERY_STRING'}) { # If this can contain '`"-quotes, be carefull to use it QUOTED $default_values{CGI_Decoded_QS} = YOUR_CGIQUERYDECODE(); $default_values{CGI_Content_Length} = length($default_values{CGI_Decoded_QS}); }; # # Get the current Date and time and store them as default variables # # Get Local Time $LocalTime = localtime; # # CGI_Year CGI_Month CGI_Day CGI_WeekDay CGI_Time # CGI_Hour CGI_Minutes CGI_Seconds # $default_values{CGI_Date} = $LocalTime; ($default_values{CGI_WeekDay}, $default_values{CGI_Month}, $default_values{CGI_Day}, $default_values{CGI_Time}, $default_values{CGI_Year}) = split(' ', $LocalTime); ($default_values{CGI_Hour}, $default_values{CGI_Minutes}, $default_values{CGI_Seconds}) = split(':', $default_values{CGI_Time}); # # GMT: # CGI_GMTYear CGI_GMTMonth CGI_GMTDay CGI_GMTWeekDay CGI_GMTYearDay # CGI_GMTHour CGI_GMTMinutes CGI_GMTSeconds CGI_GMTisdst # ($default_values{CGI_GMTSeconds}, $default_values{CGI_GMTMinutes}, $default_values{CGI_GMTHour}, $default_values{CGI_GMTDay}, $default_values{CGI_GMTMonth}, $default_values{CGI_GMTYear}, $default_values{CGI_GMTWeekDay}, $default_values{CGI_GMTYearDay}, $default_values{CGI_GMTisdst}) = gmtime; # } # # End of Initialize Request # ################################################################### # # SECURITY: ACCESS CONTROL # # Check the credentials of each client (use pattern matching, domain first). # This subroutine will kill-off (die) the current process whenever access # is denied. sub Access_Control { # >>>>>>>>>>Start Remove # # ACCEPTED CLIENTS # # Only accept clients which are authorized, reject all unnamed clients # if REMOTE_HOST is given. # If file patterns are given, check whether the user is authorized for # THIS file. if($CGI_Accept) { # Use local variables, REMOTE_HOST becomes '-' if undefined my $REMOTE_HOST = $ENV{REMOTE_HOST} || '-'; my $REMOTE_ADDR = $ENV{REMOTE_ADDR}; my $PATH_INFO = $ENV{'PATH_INFO'}; open(CGI_Accept, "<$CGI_Accept") || dieHandler(3, "$CGI_Accept: $!\n"); $NoAccess = 1; while() { next unless /\S/; # Skip empty lines next if /^\s*\#/; # Skip comments # Full expressions if(/^\s*-e\s/is) { my $Accept = $'; # Get the expression $NoAccess &&= eval($Accept); # evaluate the expresion } else { my ($Accept, @FilePatternList) = split; if($Accept eq '*' # Always match ||$REMOTE_HOST =~ /\Q$Accept\E$/is # REMOTE_HOST matches || ( $Accept =~ /^[0-9\.]+$/ && $REMOTE_ADDR =~ /^\Q$Accept\E/ # IP address matches ) ) { if($FilePatternList[0]) { foreach $Pattern (@FilePatternList) { # Check whether this patterns is accepted $NoAccess &&= ($PATH_INFO !~ m@\Q$Pattern\E@is); }; } else { $NoAccess = 0; # No file patterns -> Accepted }; }; }; # Blocked last unless $NoAccess; }; close(CGI_Accept); if($NoAccess){ dieHandler(4, "No Access: $PATH_INFO\n");}; }; # # # REJECTED CLIENTS # # Reject named clients, accept all unnamed clients if($CGI_Reject) { # Use local variables, REMOTE_HOST becomes '-' if undefined my $REMOTE_HOST = $ENV{'REMOTE_HOST'} || '-'; my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'}; my $PATH_INFO = $ENV{'PATH_INFO'}; open(CGI_Reject, "<$CGI_Reject") || dieHandler(5, "$CGI_Reject: $!\n"); $NoAccess = 0; while() { next unless /\S/; # Skip empty lines next if /^\s*\#/; # Skip comments # Full expressions if(/^-e\s/is) { my $Reject = $'; # Get the expression $NoAccess ||= eval($Reject); # evaluate the expresion } else { my ($Reject, @FilePatternList) = split; if($Reject eq '*' # Always match ||$REMOTE_HOST =~ /\Q$Reject\E$/is # REMOTE_HOST matches ||($Reject =~ /^[0-9\.]+$/ && $REMOTE_ADDR =~ /^\Q$Reject\E/is # IP address matches ) ) { if($FilePatternList[0]) { foreach $Pattern (@FilePatternList) { $NoAccess ||= ($PATH_INFO =~ m@\Q$Pattern\E@is); }; } else { $NoAccess = 1; # No file patterns -> Rejected }; }; }; last if $NoAccess; }; close(CGI_Reject); if($NoAccess){ dieHandler(6, "Request rejected: $PATH_INFO\n");}; }; # ##########################################################<<<<<<<<<, or <) dieHandler(7, "Illegal request: $ENV{'PATH_INFO'}\n") if $ENV{'PATH_INFO'} =~ /[^$FileAllowedChars]/; # Does the pathname contain an illegal (blocked) "directory" dieHandler(8, "Illegal request: $ENV{'PATH_INFO'}\n") if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@; # Access is blocked # Does the pathname contain a direct referencer to BinaryMapFile dieHandler(9, "Illegal request: $ENV{'PATH_INFO'}\n") if $BinaryMapFile && $ENV{'PATH_INFO'} =~ m@\Q$BinaryMapFile\E@; # Access is blocked # SECURITY: Is PATH_INFO allowed? if($FilePattern && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} ne '-' && ($ENV{'PATH_INFO'} !~ m@($FilePattern)$@is)) { # Unsupported file types can be processed by a special raw-file if($BinaryMapFile) { $ENV{'CGI_BINARY_FILE'} = $ENV{'PATH_INFO'}; $ENV{'PATH_INFO'} = $BinaryMapFile; } else { dieHandler(10, "Illegal file\n"); }; }; } # # End of Security Access Control # # ############################################################################ # # Get the POST part of the query and add it to the QUERY_STRING. # # sub Get_POST_part_of_query { # # If POST, Read data from stdin to QUERY_STRING if($ENV{'REQUEST_METHOD'} =~ /POST/is) { # SECURITY: Check size of Query String $ENV{'CONTENT_LENGTH'} <= $MaximumQuerySize || dieHandler(11, "Query too long: $ENV{'CONTENT_LENGTH'}\n"); # Query too long my $QueryRead = 0; my $SystemRead = $ENV{'CONTENT_LENGTH'}; $ENV{'QUERY_STRING'} .= '&' if length($ENV{'QUERY_STRING'}) > 0; while($SystemRead > 0) { $QueryRead = sysread(STDIN, $Post, $SystemRead); # Limit length $ENV{'QUERY_STRING'} .= $Post; $SystemRead -= $QueryRead; }; # Update decoded Query String $default_values{CGI_Decoded_QS} = YOUR_CGIQUERYDECODE(); $default_values{CGI_Content_Length} = length($default_values{CGI_Decoded_QS}); }; } # # End of getting POST part of query # # ############################################################################ # # Start (HTML) output and logging # (if there are irregularities, it can kill the current process) # # sub Initialize_output { # Construct the REAL file path (except for STDIN on the command line) my $file_path = $ENV{'PATH_INFO'} ne '-' ? $SS_PUB . $ENV{'PATH_INFO'} : '-'; $file_path =~ s/\?.*$//; # Remove query # This is only necessary if your server does not catch ../ directives $file_path !~ m@\.\./@ || dieHandler(12, "Illegal ../ Construct\n"); # SECURITY: Do not allow ../ constructs # Block STDIN use (-) if CGIscriptor is servicing a HTTP request if($file_path eq '-') { dieHandler(13, "STDIN request in On Line system\n") if $BLOCK_STDIN_HTTP_REQUEST && ($ENV{'SERVER_SOFTWARE'} || $ENV{'SERVER_NAME'} || $ENV{'GATEWAY_INTERFACE'} || $ENV{'SERVER_PROTOCOL'} || $ENV{'SERVER_PORT'} || $ENV{'REMOTE_ADDR'} || $ENV{'HTTP_USER_AGENT'}); }; # # if($ClientLog) { open(ClientLog, ">>$ClientLog"); print ClientLog "$LocalTime | ", ($ENV{REMOTE_USER} || "-"), " ", ($ENV{REMOTE_IDENT} || "-"), " ", ($ENV{REMOTE_HOST} || "-"), " ", $ENV{REMOTE_ADDR}, " ", $ENV{PATH_INFO}, " ", $ENV{'CGI_BINARY_FILE'}, " ", ($default_values{CGI_Content_Length} || "-"), "\n"; close(ClientLog); }; if($QueryLog) { open(QueryLog, ">>$QueryLog"); print QueryLog "$LocalTime\n", ($ENV{REMOTE_USER} || "-"), " ", ($ENV{REMOTE_IDENT} || "-"), " ", ($ENV{REMOTE_HOST} || "-"), " ", $ENV{REMOTE_ADDR}, ": ", $ENV{PATH_INFO}, " ", $ENV{'CGI_BINARY_FILE'}, "\n"; # # Write Query to Log file print QueryLog $default_values{CGI_Decoded_QS}, "\n\n"; close(QueryLog); }; # # Return the file path return $file_path; } # # End of Initialize output # # ############################################################################ # # Handle login access # # Access is based on a valid session ticket. # Session tickets should be dependend on user name # and IP address. The patterns of URLs for which a # session ticket is needed and the login URL are stored in # %TicketRequiredPatterns as: # 'RegEx pattern' -> 'SessionPath\tPasswordPath\tLogin URL\tExpiration' # # sub Log_In_Access # () -> 0 = Access Allowed, Login page if access is not allowed { # No patterns, no login goto Return unless %TicketRequiredPatterns; # Get and initialize values (watch out for stuff processed by BinaryMap files) my ($SessionPath, $PasswordsPath, $Login, $valid_duration) = ("", "", "", 0); my $PATH_INFO = $ENV{'CGI_BINARY_FILE'} ? $ENV{'CGI_BINARY_FILE'} : $ENV{'PATH_INFO'}; my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'}; goto Return if $REMOTE_ADDR =~ /[^0-9\.]/; # Extract TICKETs, starting with returned cookies CGIexecute::defineCGIvariable('LOGINTICKET', ""); CGIexecute::defineCGIvariable('SESSIONTICKET', ""); CGIexecute::defineCGIvariable('CHALLENGETICKET', ""); Get_All_Cookies(); if(length(keys(%CGI_Cookies)) > 0) { ${"CGIexecute::LOGINTICKET"} = $CGI_Cookies{'CGIscriptorLOGIN'} if $CGI_Cookies{'CGIscriptorLOGIN'} && $CGI_Cookies{'CGIscriptorLOGIN'} ne "-"; $CGI_Cookies{'CGIscriptorLOGIN'} = "-"; ${"CGIexecute::CHALLENGETICKET"} = $CGI_Cookies{'CGIscriptorCHALLENGE'} if $CGI_Cookies{'CGIscriptorCHALLENGE'} && $CGI_Cookies{'CGIscriptorCHALLENGE'} ne "-"; $CGI_Cookies{'CGIscriptorCHALLENGE'} = "-"; ${"CGIexecute::SESSIONTICKET"} = $CGI_Cookies{'CGIscriptorSESSION'} if $CGI_Cookies{'CGIscriptorSESSION'} && $CGI_Cookies{'CGIscriptorSESSION'} ne "-"; $CGI_Cookies{'CGIscriptorSESSION'} = "-"; }; # Get and check the tickets. Tickets are restricted to word-characters (alphanumeric+_+.) my $LOGINTICKET = ${"CGIexecute::LOGINTICKET"}; goto Return if ($LOGINTICKET && $LOGINTICKET =~ /[^\w\.]/isg); my $SESSIONTICKET = ${"CGIexecute::SESSIONTICKET"}; goto Return if ($SESSIONTICKET && $SESSIONTICKET =~ /[^\w\.]/isg); my $CHALLENGETICKET = ${"CGIexecute::CHALLENGETICKET"}; goto Return if ($CHALLENGETICKET && $CHALLENGETICKET =~ /[^\w\.]/isg); # Look for a LOGOUT message my $LOGOUT = $ENV{QUERY_STRING} =~ /(^|\&)LOGOUT([\=\&]|$)/; # Username and password CGIexecute::defineCGIvariable('CGIUSERNAME', ""); my $username = lc(${"CGIexecute::CGIUSERNAME"}); goto Return if $username =~ m!^[^\w]!isg || $username =~ m![^\w \-]!isg; my $userfile = lc($username); $userfile =~ s/[^\w]/_/isg; CGIexecute::defineCGIvariable('PASSWORD', ""); my $password = ${"CGIexecute::PASSWORD"}; CGIexecute::defineCGIvariable('NEWUSERNAME', ""); my $newuser = lc(${"CGIexecute::NEWUSERNAME"}); CGIexecute::defineCGIvariable('NEWPASSWORD', ""); my $newpassword = ${"CGIexecute::NEWPASSWORD"}; # foreach my $pattern (keys(%TicketRequiredPatterns)) { # Check BOTH the real PATH_INFO and the CGI_BINARY_FILE variable if($ENV{'PATH_INFO'} =~ m#$pattern# || $ENV{'CGI_BINARY_FILE'} =~ m#$pattern#) { # Fall through a sieve of requirements ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern}); # Is there a change password request? if($newuser && $LOGINTICKET && $username) { goto Login unless (-s "$SessionPath/$LOGINTICKET"); goto Login unless (-s "$PasswordsPath/$userfile"); my $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; $ticket_valid = check_ticket_validity("LOGIN", "$SessionPath/$LOGINTICKET", $REMOTE_ADDR, ".", 1); goto Login unless $ticket_valid; my ($sessiontype, $currentticket) = ("", ""); if($CHALLENGETICKET) {($sessiontype, $currentticket) = ("CHALLENGE", $CHALLENGETICKET);} elsif($SESSIONTICKET) {($sessiontype, $currentticket) = ("SESSION", $SESSIONTICKET);} elsif(-s "$SessionPath/$REMOTE_ADDR") {($sessiontype, $currentticket) = ("IPADDRESS", $REMOTE_ADDR); }; if($sessiontype) { goto Login unless (-s "$SessionPath/$currentticket"); my $ticket_valid = check_ticket_validity($sessiontype, "$SessionPath/$currentticket", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; } # Authorize my $TMPTICKET = authorize_login("$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $password, $SessionPath, $REMOTE_ADDR); goto Login unless $TMPTICKET; # Create a new user account CGIexecute::defineCGIvariable('NEWSESSION', ""); my $newsession = ${"CGIexecute::NEWSESSION"}; my $newaccount = create_newuser("$SessionPath/$LOGINTICKET", "$SessionPath/$currentticket", "$PasswordsPath/$userfile", $password, $newuser, $newpassword, $newsession); CGIexecute::defineCGIvariable('NEWACCOUNTTEXT', $newaccount); ${CGIexecute::NEWACCOUNTTEXT} = $newaccount; # NEWACCOUNTTEXT is NOT to be set by the query CGIexecute::ProtectCGIvariable('NEWACCOUNTTEXT'); # Ready goto Return; } # Is there a change password request? elsif($newpassword && $LOGINTICKET && $username) { goto Login unless (-s "$SessionPath/$LOGINTICKET"); goto Login unless (-s "$PasswordsPath/$userfile"); my $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; $ticket_valid = check_ticket_validity("LOGIN", "$SessionPath/$LOGINTICKET", $REMOTE_ADDR, ".", 1); goto Login unless $ticket_valid; my ($sessiontype, $currentticket) = ("", ""); if($CHALLENGETICKET) {($sessiontype, $currentticket) = ("CHALLENGE", $CHALLENGETICKET);} elsif($SESSIONTICKET) {($sessiontype, $currentticket) = ("SESSION", $SESSIONTICKET);} elsif(-s "$SessionPath/$REMOTE_ADDR") {($sessiontype, $currentticket) = ("IPADDRESS", $REMOTE_ADDR); }; if($sessiontype) { goto Login unless (-s "$SessionPath/$currentticket"); my $ticket_valid = check_ticket_validity($sessiontype, "$SessionPath/$currentticket", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; } # Authorize change_password("$SessionPath/$LOGINTICKET", "$SessionPath/$currentticket", "$PasswordsPath/$userfile", $password, $newpassword); # After a change of password, you have to login again for a CHALLENGE if($CHALLENGETICKET){$CHALLENGETICKET = "";}; # Ready goto Return; } # Is there a login ticket of this name? elsif($LOGINTICKET) { goto Login unless (-s "$SessionPath/$LOGINTICKET"); goto Login unless (-s "$PasswordsPath/$userfile"); my $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; $ticket_valid = check_ticket_validity("LOGIN", "$SessionPath/$LOGINTICKET", $REMOTE_ADDR, "."); goto Login unless $ticket_valid; # Authorize my $TMPTICKET = authorize_login("$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $password, $SessionPath, $REMOTE_ADDR); if($TMPTICKET) { my $authorization = read_ticket("$PasswordsPath/$userfile"); goto Login unless $authorization; # Session type is read from the userfile if($authorization->{"Session"} && $authorization->{"Session"}->[0] eq "CHALLENGE") { # Create New Random CHALLENGETICKET $CHALLENGETICKET = $TMPTICKET; create_session_file("$SessionPath/$CHALLENGETICKET", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO); } elsif($authorization->{"Session"} && $authorization->{"Session"}->[0] eq "IPADDRESS") { create_session_file("$SessionPath/$REMOTE_ADDR", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO); } else { # Extra hash to protect CHALLENGETICKET use $SESSIONTICKET = hash_string($TMPTICKET); $SESSIONTICKET = hash_string($SESSIONTICKET.$TMPTICKET); create_session_file("$SessionPath/$SESSIONTICKET", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO); $SETCOOKIELIST{"CGIscriptorSESSION"} = "-"; $TMPTICKET = $SESSIONTICKET; }; }; # Login ticket file has been used, remove it unlink($loginfile); }; # Is there a session ticket of this name? # CHALLENGE if($CHALLENGETICKET) { # Do not log into a CHALLENGE account if the SESSION cookie is present # Uncomment when $SESSIONTICKET does not receive an extra hash #goto Login if $SESSIONTICKET =~ /\S/; goto Login unless (-s "$SessionPath/$CHALLENGETICKET"); my $ticket_valid = check_ticket_validity("CHALLENGE", "$SessionPath/$CHALLENGETICKET", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; my $oldchallenge = read_ticket("$SessionPath/$CHALLENGETICKET"); goto Login unless $oldchallenge; # Check whether the login still exists my $userfile = lc($oldchallenge->{"Username"}->[0]); $userfile =~ s/[^\w]/_/isg; goto Login unless (-s "$PasswordsPath/$userfile"); $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; # This is a LOGOUT request, clean up (Access has already been validated) if($LOGOUT) { unlink "$SessionPath/$CHALLENGETICKET" if $CHALLENGETICKET && (-s "$SessionPath/$CHALLENGETICKET"); $CHALLENGETICKET = ""; goto Login; }; my $NEWCHALLENGETICKET = ""; $NEWCHALLENGETICKET = copy_challenge_file("$SessionPath/$CHALLENGETICKET", "$PasswordsPath/$userfile", $SessionPath); # Sessionticket is available to scripts, do NOT set the cookie $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET; goto Return; } # IPADDRESS elsif(-s "$SessionPath/$REMOTE_ADDR") { my $ticket_valid = check_ticket_validity("IPADDRESS", "$SessionPath/$REMOTE_ADDR", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; # Check whether the login still exists my $currentsessionticket = read_ticket("$SessionPath/$REMOTE_ADDR"); my $userfile = lc($currentsessionticket->{"Username"}->[0]); $userfile =~ s/[^\w]/_/isg; goto Login unless (-s "$PasswordsPath/$userfile"); $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; # This is a LOGOUT request, clean up (Access has already been validated) if($LOGOUT) { unlink "$SessionPath/$REMOTE_ADDR" if (-s "$SessionPath/$REMOTE_ADDR"); goto Login; }; goto Return; } # SESSION elsif($SESSIONTICKET) { goto Login unless (-s "$SessionPath/$SESSIONTICKET"); my $ticket_valid = check_ticket_validity("SESSION", "$SessionPath/$SESSIONTICKET", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; # Check whether the login still exists my $currentsessionticket = read_ticket("$SessionPath/$SESSIONTICKET"); my $userfile = lc($currentsessionticket->{"Username"}->[0]); $userfile =~ s/[^\w]/_/isg; goto Login unless (-s "$PasswordsPath/$userfile"); $ticket_valid = check_ticket_validity("PASSWORD", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO); goto Login unless $ticket_valid; # This is a LOGOUT request, clean up (Access has already been validated) if($LOGOUT) { unlink "$SessionPath/$SESSIONTICKET" if $SESSIONTICKET && (-s "$SessionPath/$SESSIONTICKET"); $SESSIONTICKET = ""; goto Login; }; # Sessionticket is available to scripts $ENV{'SESSIONTICKET'} = $SESSIONTICKET; goto Return; }; goto Login; goto Return; }; }; Return: # The Masterkey should NOT be accessible by the parsed files $ENV{'CGIMasterKey'} = "" if $ENV{'CGIMasterKey'}; return 0; Login: # To deter DOS attacks, do not remove valid session tickets unless the # "owner" has accredited herself my $tickets_removed = remove_expired_tickets($SessionPath); create_login_file($PasswordsPath, $SessionPath, $REMOTE_ADDR); # Note, cookies are set only ONCE $SETCOOKIELIST{"CGIscriptorLOGIN"} = "-"; # The Masterkey should NOT be accessible by the parsed files $ENV{'CGIMasterKey'} = "" if $ENV{'CGIMasterKey'}; return "$YOUR_HTML_FILES/$Login"; }; sub authorize_login # ($loginfile, $authorizationfile, $password, $SessionPath, $IPaddress) => SESSIONTICKET First two arguments are file paths { my $loginfile = shift || ""; my $authorizationfile = shift || ""; my $password = shift || ""; my $SessionPath = shift || ""; my $RemoteIPaddress = shift || ""; # Get Login session ticket my $loginticket = read_ticket($loginfile); return 0 unless $loginticket; # Get User credentials for authorization my $authorization = read_ticket($authorizationfile); return 0 unless $authorization; # Get Randomsalt my $Randomsalt = $loginticket->{'Randomsalt'}->[0]; return "" unless $Randomsalt; my $storedpassword = $authorization->{'Password'}->[0]; return "" unless $storedpassword; my $Hashedpassword = hash_string($storedpassword.$RemoteIPaddress.$Randomsalt); return "" unless $password eq $Hashedpassword; # Extract Session Ticket my $loginsession = $loginticket->{'Session'}->[0]; my $sessionticket = hash_string($storedpassword.$loginsession); chomp($sessionticket); $sessionticket = "" if -x "$SessionPath/$sessionticket"; # No lingering password variables $Hashedpassword = $Randomsalt; $password = $Randomsalt; $authorization->{'Password'}->[0] = $Randomsalt; return $sessionticket; }; sub change_password # ($loginfile, $sessionfile, $authorizationfile, $password, $newpassword) First three arguments are file paths { my $loginfile = shift || ""; my $sessionfile = shift || ""; my $authorizationfile = shift || ""; my $password = shift || ""; my $newpassword = shift || ""; # Get Login session ticket my $loginticket = read_ticket($loginfile); return "" unless $loginticket; # Login ticket file has been used, remove it unlink($loginfile); # Get Randomsalt my $Randomsalt = $loginticket->{'Randomsalt'}->[0]; return "" unless $Randomsalt; my $LoginID = $loginticket->{'Session'}->[0]; return "" unless $LoginID; # Get session ticket my $sessionticket = read_ticket($sessionfile); return "" unless $sessionticket; # Get User credentials for authorization my $authorization = read_ticket($authorizationfile); return "" unless $authorization && lc($authorization->{'Username'}->[0]) eq lc($sessionticket->{'Username'}->[0]); my $storedpassword = $authorization->{'Password'}->[0]; my $Hashedpassword = hash_string($storedpassword.$Randomsalt); return "" unless $password eq $Hashedpassword; my $secretkey = hash_string($storedpassword.$LoginID.$Randomsalt); # Decrypt the $newpassword my $decryptedPassword = XOR_hex_strings($secretkey, $newpassword); return "" unless $decryptedPassword; # Authorization succeeded, change password $authorization->{'Password'}->[0] = $decryptedPassword; # Write out write_ticket($authorizationfile, $authorization, $authorization->{'Salt'}->[0]); # No lingering password variables $decryptedPassword = $Randomsalt; $secretkey = $Randomsalt; $storedpassword = $Randomsalt; $Hashedpassword = $Randomsalt; $authorization->{'Password'}->[0] = $Randomsalt; return $newpassword; }; # First three arguments are file paths sub create_newuser # ($loginfile, $sessionfile, $authorizationfile, $password, $newuser, $newpassword, $newsession) -> account text { my $loginfile = shift || ""; my $sessionfile = shift || ""; my $authorizationfile = shift || ""; my $password = shift || ""; my $newuser = shift || ""; my $newpassword = shift || ""; my $newsession = shift || ""; # Get Login session ticket my $loginticket = read_ticket($loginfile); return "" unless $loginticket; # Login ticket file has been used, remove it unlink($loginfile); # Get Randomsalt my $Randomsalt = $loginticket->{'Randomsalt'}->[0]; return "" unless $Randomsalt; my $LoginID = $loginticket->{'Session'}->[0]; return "" unless $LoginID; # Get session ticket my $sessionticket = read_ticket($sessionfile); return "" unless $sessionticket; # Get User credentials for authorization my $authorization = read_ticket($authorizationfile); return "" unless $authorization && lc($authorization->{'Username'}->[0]) eq lc($sessionticket->{'Username'}->[0]); my $sessionkey = $sessionticket->{'Key'}->[0]; my $serversalt = $authorization->{'Salt'}->[0]; return "" unless $serversalt; my $storedpassword = $authorization->{'Password'}->[0]; my $Hashedpassword = hash_string($storedpassword.$Randomsalt); return "" unless $password eq $Hashedpassword; my $secretkey = hash_string($storedpassword.$LoginID.$Randomsalt); # Decrypt the $newpassword my $decryptedPassword = XOR_hex_strings($secretkey, $newpassword); return "" unless $decryptedPassword; # Authorization succeeded, create new account my $newaccount = {}; $newaccount->{'Type'} = ['PASSWORD']; $newaccount->{'Username'} = [$newuser]; $newaccount->{'Password'} = [$decryptedPassword]; $newaccount->{'Salt'} = [$serversalt]; $newaccount->{'Session'} = ['SESSION']; if($newsession eq 'IPADDRESS'){$newaccount->{'Session'} = ['IPADDRESS'];}; if($newsession eq 'CHALLENGE'){$newaccount->{'Session'} = ['CHALLENGE'];}; my $timesec = time(); my $gmt_date = gmtime(); $newaccount->{'Time'} = [$timesec]; $newaccount->{'Date'} = [$gmt_date]; # AllowedPaths my $NewAllowedPaths = ""; my $PATH_INFO = $ENV{'CGI_BINARY_FILE'} ? $ENV{'CGI_BINARY_FILE'} : $ENV{'PATH_INFO'}; my $currentRoot = ""; $currentRoot = $1 if $PATH_INFO =~ m!^([\w\-\. /]+)!isg; $currentRoot =~ s![^/]+$!!isg; if($currentRoot) { $currentRoot .= '/' unless $currentRoot =~ m!/$!; my $newpath = "^".${currentRoot}.'[\w\-]+\.html?'; $NewAllowedPaths .= 'AllowedPaths: ^'.${currentRoot}.'[\w\-]+\.html?'."\n"; $newaccount->{'AllowedPaths'} = [$newpath]; } else { # Tricky PATH_INFO, deny all $NewAllowedPaths .= "DeniedPaths: ^/\n"; $newaccount->{'DeniedPaths'} = ["DeniedPaths: ^/\n"]; }; # Construct home directory path my $FullHomeDirectoryPath = ""; my $currentHome = lc($newuser); if($currentHome && $currentHome !~ /^\s*\#/) { $currentHome =~ s![^\w]!_!isg; my $newpath = "^${currentRoot}$currentHome/"; push(@{$newaccount->{'AllowedPaths'}}, $newpath); # Create home directory $FullHomeDirectoryPath = $ENV{'HOME'}.${currentRoot}.$currentHome; }; # Allowed Paths CGIexecute::defineCGIvariable('ALLOWEDPATHS', ""); my $allowedpaths = ${"CGIexecute::ALLOWEDPATHS"}; if($allowedpaths && $allowedpaths !~ /^\s*\#/) { $allowedpaths =~ s!\#.*$!!isg; $allowedpaths =~ s![^\^\w\./\;\+\*\?\[\]\$]!!isg; my @pathlist = split(/\;/, $allowedpaths); foreach my $entry (@pathlist) { push(@{$newaccount->{'AllowedPaths'}}, "^".${currentRoot}.$entry); }; }; # Allowed IP addresses CGIexecute::defineCGIvariable('IPADDRESS', ""); my $ipaddress = ${"CGIexecute::IPADDRESS"}; if($ipaddress && $ipaddress !~ /^\s*\#/) { $ipaddress =~ s!\#.*$!!isg; $ipaddress =~ s![^\d\.\;]!!isg; my @iplist = split(/\;/, $ipaddress); foreach my $entry (@iplist) { next unless $entry =~ /\d/; next if $entry =~ /^\s*\#/; $entry =~ s/\./\\./g; push(@{$newaccount->{'IPaddress'}}, $entry); }; }; # Capabilities CGIexecute::defineCGIvariable('NEWCAPABILITIES', ""); my $capabilities = ${"CGIexecute::NEWCAPABILITIES"}; if($capabilities && $capabilities !~ /^\W*\#/) { $capabilities =~ s!\#.*$!!isg; $capabilities =~ s![^\w\s]!!isg; my @caplist = split(/\s/, $capabilities); foreach my $entry (@caplist) { next unless $entry =~ /\w/; next if $entry =~ /^\s*\#/; push(@{$newaccount->{'Capabilities'}}, $entry); }; }; # Sign the new ticket my $Signature = SignTicketWithMasterkey($newaccount, $newaccount->{'Salt'}->[0]); # Write my $datetime = gmtime(); my $newuserfile = ""; if(grep(/^CreateUser$/, @{$authorization->{'Capabilities'}})) { my $newuserfilename = lc($newuser); $newuserfilename =~ s/[^\w]/_/isg; $newuserfile = $authorizationfile; $newuserfile =~ s![^/]*$!!isg; $newuserfile .= $newuserfilename; if(-s $newuserfile) { $newuserfile = ""; } elsif($FullHomeDirectoryPath && !(-d $FullHomeDirectoryPath || -s $FullHomeDirectoryPath)) { if(-d "$ENV{'HOME'}${currentRoot}.SkeletonDir") { `cp -r '$ENV{'HOME'}${currentRoot}.SkeletonDir' '$FullHomeDirectoryPath'`; } elsif(-d "$ENV{'HOME'}${currentRoot}SkeletonDir") { `cp -r '$ENV{'HOME'}${currentRoot}SkeletonDir' '$FullHomeDirectoryPath'`; } elsif(-s "$ENV{'HOME'}${currentRoot}UserIndex.html") { mkdir $FullHomeDirectoryPath; `cp '$ENV{'HOME'}${currentRoot}UserIndex.html' '$FullHomeDirectoryPath/index.html'`; } elsif(-s "$ENV{'HOME'}${currentRoot}index.html") { mkdir $FullHomeDirectoryPath; `cp '$ENV{'HOME'}${currentRoot}index.html' '$FullHomeDirectoryPath/index.html'`; } ; }; }; my $newaccounttext = write_ticket($newuserfile, $newaccount, $serversalt); # Re-encrypt the new password for transmission if($newaccounttext =~ /^(Password\:\s+)(\S+)\s*$/) { my $passwordvalue = $1; my $reencryptedpassword = XOR_hex_strings($secretkey, $passwordvalue); my $encryptedpasswordline = "$reencryptedpassword"; $newaccounttext =~ s/^(Password\:\s+)(\S+)\s*$/\1$encryptedpasswordline/gim; # No lingering passwords $passwordvalue = $serversalt; }; return $newaccounttext; }; # Copy a Challenge ticket file to a new name which is the hash of the new $CHALLENGETICKET and the password sub copy_challenge_file #($oldchallengefile, $authorizationfile, $sessionpath) -> $CHALLENGETICKET { my $oldchallengefile = shift || ""; my $authorizationfile = shift || ""; my $sessionpath = shift || ""; $sessionpath =~ s!/+$!!g; # Get Login session ticket my $oldchallenge = read_ticket($oldchallengefile); return "" unless $oldchallenge; # Get Authorization (user) session file my $authorization = read_ticket($authorizationfile); return "" unless $authorization; my $storedpassword = $authorization->{'Password'}->[0]; return "" unless $storedpassword; my $challengekey = $oldchallenge->{'Key'}->[0]; return "" unless $challengekey; # Create Random Hash Salt my $NEWCHALLENGETICKET = get_random_hex();; my $newchallengefile = hash_string($challengekey.$NEWCHALLENGETICKET); return "" unless $newchallengefile; $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET; CGIexecute::defineCGIvariable('CHALLENGETICKET', ""); ${"CGIexecute::CHALLENGETICKET"} = $NEWCHALLENGETICKET; # Write Session Ticket open(OLDCHALLENGE, "<$oldchallengefile") || die "<$oldchallengefile: $!\n"; my @OldChallengeLines = ; close(OLDCHALLENGE); # Old file should now be removed unlink($oldchallengefile); open(SESSION, ">$sessionpath/$newchallengefile") || die "$sessionpath/$newchallengefile: $!\n"; foreach $line (@OldChallengeLines) { print SESSION $line; }; close(SESSION); # No lingering passwords $storedpassword = $oldchallenge; return $NEWCHALLENGETICKET; }; sub create_login_file #($PasswordDir, $SessionDir, $IPaddress) { my $PasswordDir = shift || ""; my $SessionDir = shift || ""; my $IPaddress = shift || ""; # Create Login Ticket my $LOGINTICKET= get_random_hex (); # Create Random Hash Salt my $RANDOMSALT= get_random_hex(); # Create SALT file if it does not exist # Remove this, including test account for life system unless(-d "$SessionDir") { `mkdir -p "$SessionDir"`; }; unless(-d "$PasswordDir") { `mkdir -p "$PasswordDir"`; }; # Create SERVERSALT and default test account my $SERVERSALT = ""; unless(-s "$PasswordDir/SALT") { $SERVERSALT= get_random_hex(); open(SALTFILE, ">$PasswordDir/SALT") || die ">$PasswordDir/SALT: $!\n"; print SALTFILE "$SERVERSALT\n"; close(SALTFILE); # Update test account (should be removed in live system) my @alltestusers = ("test", "testip", "testchallenge", "admin"); foreach my $testuser (@alltestusers) { if(-s "$PasswordDir/$testuser") { my $plainpassword = $testuser eq 'admin' ? "There is no password like more password" : "testing"; my $storedpassword = hash_string(${plainpassword}.${testuser}.${SERVERSALT}); # Encrypt the new password with the MasterKey my $authorization = read_ticket("$PasswordDir/$testuser") || return ""; $authorization->{'Salt'} = [$SERVERSALT]; $authorization->{'Type'} = ['INACTIVE PASSWORD'] if $testuser eq 'admin'; set_password($authorization, $SERVERSALT, $plainpassword); write_ticket("$PasswordDir/$testuser", $authorization, $SERVERSALT); # No lingering passwords $storedpassword = $SERVERSALT; $plainpassword = $SERVERSALT; }; }; }; # Read in site Salt open(SALTFILE, "<$PasswordDir/SALT") || die "$PasswordDir/SALT: $!\n"; $SERVERSALT=; close(SALTFILE); chomp($SERVERSALT); # Create login session ticket my $datetime = gmtime(); my $timesec = time(); my $loginticket = {}; $loginticket->{Type} = ['LOGIN']; $loginticket->{IPaddress} = [$IPaddress]; $loginticket->{Salt} = [$SERVERSALT]; $loginticket->{Session} = [$LOGINTICKET]; $loginticket->{Randomsalt} = [$RANDOMSALT]; $loginticket->{Expires} = ['+600s']; $loginticket->{Date} = ["$datetime UTC"]; $loginticket->{Time} = [$timesec]; write_ticket("$SessionDir/$LOGINTICKET", $loginticket, $SERVERSALT); # Set global variables # $SERVERSALT $ENV{'SERVERSALT'} = $SERVERSALT; CGIexecute::defineCGIvariable('SERVERSALT', ""); ${"CGIexecute::SERVERSALT"} = $SERVERSALT; # $SESSIONTICKET $ENV{'SESSIONTICKET'} = $SESSIONTICKET; CGIexecute::defineCGIvariable('SESSIONTICKET', ""); ${"CGIexecute::SESSIONTICKET"} = $SESSIONTICKET; # $RANDOMSALT $ENV{'RANDOMSALT'} = $RANDOMSALT; CGIexecute::defineCGIvariable('RANDOMSALT', ""); ${"CGIexecute::RANDOMSALT"} = $RANDOMSALT; # $LOGINTICKET $ENV{'LOGINTICKET'} = $LOGINTICKET; CGIexecute::defineCGIvariable('LOGINTICKET', ""); ${"CGIexecute::LOGINTICKET"} = $LOGINTICKET; return $ENV{'LOGINTICKET'}; }; sub create_session_file #($sessionfile, $loginfile, $authorizationfile, $path) -> Is $loginfile deleted? 0/1 { my $sessionfile = shift || ""; my $loginfile = shift || ""; my $authorizationfile = shift || ""; my $path = shift || ""; # Get Login session ticket my $loginticket = read_ticket($loginfile); return unlink($loginfile) unless $loginticket; # Get Authorization (user) session file my $authorization = read_ticket($authorizationfile); return unlink($loginfile) unless $authorization; # For a Session or a Challenge, we need a stored key my $sessionkey = ""; my $secretkey = ""; if($authorization->{'Session'} && $authorization->{'Session'}->[0] ne 'IPADDRESS') { my $storedpassword = $authorization->{'Password'}->[0]; my $loginticketid = $loginticket->{'Session'}->[0]; my $randomsalt = $loginticket->{'Randomsalt'}->[0]; $sessionkey = hash_string($storedpassword.$loginticketid); $secretkey = hash_string($storedpassword.$loginticketid.$randomsalt); # No lingering passwords $storedpassword = $loginticketid; }; # Get Session id my $sessionid = ""; if($sessionfile =~ m!([^/]+)$!) { $sessionid = $1; }; # Convert Authorization content to Session content my $sessionContent = {}; my $SessionType = $authorization->{'Session'}->[0] ? $authorization->{'Session'}->[0] : "SESSION"; $sessionContent->{Type} = [$SessionType]; $sessionContent->{Username} = [lc($authorization->{'Username'}->[0])]; $sessionContent->{Session} = [$sessionid]; $sessionContent->{Time} = [time]; # Limit communication to the login IP address, except for Tor like situations with VariableREMOTE_ADDR $sessionContent->{IPaddress} = ['.']; if($sessionContent->{Type}->[0] eq 'CHALLENGE' && grep(/^VariableREMOTE_ADDR$/, @{$authorization->{'Capabilities'}})) { $sessionContent->{IPaddress} = $authorization->{'IPaddress'} if $authorization->{'IPaddress'}; } else { $sessionContent->{IPaddress} = $loginticket->{'IPaddress'}; }; $sessionContent->{Salt} = $authorization->{'Salt'}; $sessionContent->{Randomsalt} = $loginticket->{'Randomsalt'}; $sessionContent->{AllowedPaths} = $authorization->{'AllowedPaths'}; $sessionContent->{DeniedPaths} = $authorization->{'DeniedPaths'}; $sessionContent->{Expires} = $authorization->{'MaxLifetime'}; $sessionContent->{Capabilities} = $authorization->{'Capabilities'}; foreach my $pattern (keys(%TicketRequiredPatterns)) { if($path =~ m#$pattern#) { my ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern}); push(@{$sessionContent->{Expires}}, $validtime); }; }; $sessionContent->{Key} = [$sessionkey] if $sessionkey; $sessionContent->{Secretkey} = [$secretkey] if $secretkey; $sessionContent->{Date} = [gmtime()." UTC"]; # Write Session Ticket write_ticket($sessionfile, $sessionContent, $authorization->{'Salt'}->[0]); # Login file should now be removed return unlink($loginfile); }; sub check_ticket_validity # ($type, $ticketfile, $address, $path [, $unsigned]) { my $type = shift || "SESSION"; my $ticketfile = shift || ""; my $address = shift || ""; my $path = shift || ""; my $unsigned = shift || 0; # Is there a session ticket of this name? return 0 unless -s "$ticketfile"; # There is a session ticket, is it linked to this IP address? my $ticket = read_ticket($ticketfile); unless($ticket) { print STDERR "Ticket expired or empty: $ticketfile\n"; return; }; # Is this the right type of ticket unless($ticket && $ticket->{'Type'}->[0] eq $type) { print STDERR "Wrong ticket type: $ticket->{'Type'}->[0] eq $type\n"; return; }; # Does the IP address match? my $IPmatches = @{$ticket->{"IPaddress"}} ? 0 : 1; for $IPpattern (@{$ticket->{"IPaddress"}}) { ++$IPmatches if $address =~ m#^$IPpattern#ig; }; if($address && ! $IPmatches) { print STDERR "Wrong REMOTE ADDR for $ticket->{'Username'}->[0]: $ticket->{'IPaddress'}->[0] vs $address\n"; return 0; }; # Is the path denied my $Pathmatches = 0; foreach $Pathpattern (@{$ticket->{"DeniedPaths"}}) { ++$Pathmatches if $path =~ m#$Pathpattern#ig; }; return 0 if @{$ticket->{"DeniedPaths"}} && $Pathmatches; # Is the path allowed $Pathmatches = 0; foreach $Pathpattern (@{$ticket->{"AllowedPaths"}}) { ++$Pathmatches if $path =~ m#$Pathpattern#ig; }; return 0 unless !@{$ticket->{"AllowedPaths"}} || $Pathmatches; # Check signature if not told to use an unsigned ticket (dangerous) my $Signature = TicketSignature($ticket, $ticket->{'Salt'}->[0]); if((! $unsigned) && $Signature && $Signature ne $ticket->{'Signature'}->[0]) { print STDERR "Invalid signature for $ticket->{'Type'}: $ticket->{'Username'}\n$ticketfile\n"; return 0; }; # Make login values available (will also protect against resetting by query) $ENV{"LOGINUSERNAME"} = lc($ticket->{'Username'}->[0]); $ENV{"LOGINIPADDRESS"} = $address; $ENV{"LOGINPATH"} = $path; $ENV{"SESSIONTYPE"} = $type unless $type eq "PASSWORD"; # Set Capabilities, if present if($ticket->{'Username'}->[0] && @{$ticket->{'Capabilities'}}) { $ENV{'CAPABILITIES'} = $ticket->{'Username'}->[0]; CGIexecute::defineCGIvariableList('CAPABILITIES', ""); @{"CGIexecute::CAPABILITIES"} = @{$ticket->{'Capabilities'}}; # Capabilities should not be changed anymore by CGI query! }; # Capabilities are NOT to be set by the query CGIexecute::ProtectCGIvariable('CAPABILITIES'); return 1; }; # This might be run in a fork()? sub remove_expired_tickets # ($path) -> number of tickets removed { my $path = shift || ""; return 0 unless $path; $path =~ s!/+$!!g; my $removed_tickets = 0; my @ticketlist = glob("$path/*"); foreach my $ticketfile (@ticketlist) { my $ticket = read_ticket($ticketfile); unless($ticket) { unlink $ticketfile; ++$removed_tickets; }; }; return $removed_tickets; }; sub set_password # ($ticket, $salt, $plainpassword) -> $password { my $ticket = shift || ""; my $salt = shift || ""; my $plainpassword = shift || ""; my $user = lc($ticket->{'Username'}->[0]); return "" unless $user; $salt = $ticket->{'Salt'}->[0] unless $salt; my $storedpassword = hash_string(${plainpassword}.${user}.${salt}); $ticket->{'Password'} = [$storedpassword]; $ticket->{'Salt'} = [$salt]; # No lingering passwords $storedpassword = $salt; $plainpassword = $salt; return $ticket->{'Password'}->[0]; }; sub write_ticket # ($ticketfile, $ticket, $salt [, $masterkey]) -> &%ticket { my $ticketfile = shift || ""; my $ticket = shift || ""; my $salt = shift || ""; my $masterkey = shift || $ENV{'CGIMasterKey'}; # Encrypt password EncryptTicketWithMasterKey($ticket, $salt, $masterkey); # Sign the new ticket my $signature = SignTicketWithMasterkey($ticket, $salt, $masterkey); # Create ordered list with labels my @orderlist = ('Type', 'Username', 'Password', 'IPaddress', 'AllowedPaths', 'DeniedPaths', 'Expires', 'Capabilities', 'Salt', 'Session', 'Randomsalt', 'Date', 'Time', 'Signature', 'Key', 'Secretkey'); my @labellist = keys(%{$ticket}); foreach my $label (@orderlist) { @labellist = grep(!/\b$label\b/, @labellist); }; # Create ticket in text my $TicketText = ""; foreach my $label (@orderlist, @labellist) { next unless exists($ticket->{$label}) && $ticket->{$label}->[0]; foreach my $value (@{$ticket->{$label}}) { $TicketText .= "$label: $value\n"; }; }; if($ticketfile) { open(TICKET, ">$ticketfile") || die "$ticketfile: $!\n"; print TICKET $TicketText; close(TICKET); }; return $TicketText; }; # Note, read_ticket will return 0 if the ticket has expired! sub read_ticket # ($ticketfile [, $salt, $masterkey]) -> &%ticket { my $ticketfile = shift || ""; my $serversalt = shift || ""; my $masterkey = shift || $ENV{'CGIMasterKey'}; my $ticket = {}; if($ticketfile && -s $ticketfile) { open(TICKETFILE, "<$ticketfile") || die "$ticketfile: $!\n"; my @alllines = ; close(TICKETFILE); foreach my $currentline (@alllines) { # Skip empty lines and comments next unless $currentline =~ /\S/; next if $currentline =~ /^\s*\#/; if($currentline =~ /^\s*(\S[^\:]+)\:\s+(.*)\s*$/) { my $Label = $1; my $Value = $2; $ticket->{$Label} = () unless exists($ticket->{$Label}); push(@{$ticket->{$Label}}, $Value); }; }; } elsif(-z $ticketfile) { return 0; }; if($masterkey && exists($ticket->{'Password'}) && $ticket->{'Password'}->[0]) { # Use the ServerSalt stored in the ticket, if present if(!$serversalt && exists($ticket->{Salt}) && $ticket->{Salt}->[0]) { $serversalt = $ticket->{Salt}->[0]; }; # Decrypt all passwords DecryptTicketWithMasterKey($ticket, $serversalt, $masterkey) || die "Decryption failed: DecryptTicketWithMasterKey ($ticket, $serversalt)\n"; }; # Check whether the ticket has expired if(exists($ticket->{Expires})) { my $StartTime = 0; if(exists($ticket->{Time}) && $ticket->{Time}->[0] > 0) { $StartTime = [(sort(@{$ticket->{Time}}))]->[0]; } else { # Get SessionTicket file stats my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($ticketfile); $StartTime = $ctime; }; foreach my $Value (@{$ticket->{'Expires'}}) { # Recalculate expire date from relative time if($Value =~ /^\+/) { if($Value =~ /^\+(\d+)\s*d(ays)?\s*$/) { $ExpireTime = 24*3600*$1; } elsif($Value =~ /^\+(\d+)\s*m(inutes)?\s*$/) { $ExpireTime = 60*$1; } elsif($Value =~ /^\+(\d+)\s*h(ours)?\s*$/) { $ExpireTime = 3600*$1; } elsif($Value =~ /^\+(\d+)\s*s(econds)?\s*$/) { $ExpireTime = $1; } elsif($Value =~ /^\+(\d+)\s*$/) { $ExpireTime = $1; }; }; my $absoluteTime = $Value =~ /^\+/ ? $StartTime + $ExpireTime : $Value; return 0 unless $absoluteTime > time; }; @{$ticket->{Expires}} = sort(@{$ticket->{Expires}}); }; return $ticket; }; # Set up a valid ticket from a given text file # Use from command line. DO NOT USE ONLINE # Watch out for passwords that get stored in the history file # # perl CGIscriptor.pl --managelogin [options] [files] # Options: # salt={file or saltvalue} # masterkey={file or plaintext} # newmasterkey={file or plaintext} # password={file or palintext} # # Followed by one or more file names. # Options can be interspersed between filenames, # e.g., password='plaintext' # Note that passwords are only used once! # sub setup_ticket_file # (@ARGV) { # Stop when run on-line return if $ENV{'PATH_INFO'} || $ENV{'QUERY_STRING'}; my %Settings = (); foreach my $input (@_) { if($input =~ /^([\w]+)\=/) { my $name = lc($1); my $value = $'; chomp($value); ; if($value !~ m![^\w\.\~\/\:\-]! && $value !~ /^[\-\.]/ && -s "$value" && ! -d "$value") { # Warn about reading a value from file print STDERR "Read '$name' from: '$value'\n"; open(INPUTVALUE, "<$value") || die "$value: $!\n"; $value = ; chomp($value); }; $value =~ s/(^\'([^\']*)\'$)/\1/g; $value =~ s/(^\"([^\"]*)\"$)/\1/g; $Settings{$name} = $value; } elsif($input !~ m![^\w\.\~\/\:\-]!i && $input !~ /^[\-\.]/i && -s $input) { # We MUST have a salt $Settings{'salt'} = $ticket->{'Salt'}->[0] unless $Settings{'salt'}; # Set the new masterkey to the old masterkey if there is no new masterkey $Settings{'newmasterkey'} = $Settings{'masterkey'} unless exists($Settings{'newmasterkey'}); # Get the ticket my $ticket = read_ticket($input, $Settings{'salt'}, $Settings{'masterkey'}); # Set a new password from plaintext $ticket->{'Salt'}->[0] = $Settings{'salt'} if $Settings{'salt'} && $Settings{'password'}; set_password ($ticket, $Settings{'salt'}, $Settings{'password'}) if $Settings{'password'}; # Write the ticket back to file write_ticket($input, $ticket, $Settings{'salt'}, $Settings{'newmasterkey'}); # A password is only used once $Settings{'password'} = ""; }; }; }; # Add a signature from $masterkey to a ticket in the label $signlabel sub SignTicketWithMasterkey # ($ticket, $serversalt [, $masterkey, $signlabel]) -> $Signature { my $ticket = shift || return 0; my $serversalt = shift || ""; my $masterkey = shift || $ENV{'CGIMasterKey'}; my $signlabel = shift || 'Signature'; my $Signature = TicketSignature($ticket, $serversalt, $masterkey); $ticket->{$signlabel} = [$Signature] if $Signature; return $Signature; }; # Determine ticket signature sub TicketSignature # ($ticket, $serversalt [, $masterkey]) -> $Signature { my $ticket = shift || return 0; my $serversalt = shift || ""; my $masterkey = shift || $ENV{'CGIMasterKey'}; my $Signature = ""; if($masterkey) { # If the ServerSalt is not stored in the ticket, the SALT file has to be found if(!$serversalt && exists($ticket->{Salt}) && $ticket->{Salt}->[0]) { $serversalt = $ticket->{Salt}->[0]; }; # Sign if($serversalt) { my $username = lc($ticket->{'Username'}->[0]); my $hash1 = hash_string(${masterkey}.${serversalt}); # The order of $username.$hash1 should be different than in DecryptTicketWithMasterKey my $CryptKey = hash_string($username.${'hash1'}); my $SignText = "Type: ".$ticket->{'Type'}->[0]."\n"; my @tmp = sort(@{$ticket->{'Username'}}); $SignText .= "Username: @tmp\n"; @tmp = sort(@{$ticket->{'IPaddress'}}); $SignText .= "IPaddress: @tmp\n"; @tmp = sort(@{$ticket->{'AllowedPaths'}}); $SignText .= "AllowedPaths: @tmp\n"; @tmp = sort(@{$ticket->{'DeniedPaths'}}); $SignText .= "DeniedPaths: @tmp\n"; @tmp = sort(@{$ticket->{'Session'}}); $SignText .= "Session: @tmp\n"; @tmp = sort(@{$ticket->{'Time'}}); $SignText .= "Time: @tmp\n"; @tmp = sort(@{$ticket->{'Expires'}}); $SignText .= "Expires: @tmp\n"; @tmp = sort(@{$ticket->{'Capabilities'}}); $SignText .= "Capabilities: @tmp\n"; @tmp = sort(@{$ticket->{'MaxLifetime'}}); $SignText .= "MaxLifetime: @tmp\n"; $Signature = HMAC_hex($CryptKey, $SignText); }; }; return $Signature; }; # Decrypts a password list IN PLACE sub DecryptTicketWithMasterKey # ($ticket, $serversalt [, $masterkey]) -> \@password_list { my $ticket = shift || return 0; my $serversalt = shift || ""; my $masterkey = shift || $ENV{'CGIMasterKey'}; if($masterkey && exists($ticket->{Password}) && $ticket->{Password}->[0]) { # If the ServerSalt is not given, read it from the the ticket if(! $serversalt && exists($ticket->{Salt}) && $ticket->{Salt}->[0]) { $serversalt = $ticket->{Salt}->[0]; }; # Decrypt password(s) if($serversalt) { my $hash1 = hash_string(${masterkey}.${serversalt}); my $username = lc($ticket->{'Username'}->[0]); # The order of $hash1.$username should be different than in TicketSignature my $CryptKey = hash_string(${'hash1'}.$username); foreach my $password (@{$ticket->{Password}}) { $password = XOR_hex_strings($CryptKey,$password); }; }; }; return $ticket->{'Password'}; }; sub EncryptTicketWithMasterKey # ($ticket, $serversalt [, $masterkey]) -> \@password_list { DecryptTicketWithMasterKey(@_); }; # Implement HMAC signature hash. # Blocksize is length in HEX characters, NOT bytes sub HMAC_hex # ($key, $message [, $blocksizehex]) -> $hex { my $key = shift || ""; my $message = shift || ""; my $blocksizehex = shift || length($key); $key = hash_string($key) if length($key) > $blocksizehex; my $innerkey = XOR_hex_byte ($key, "36"); my $outerkey = XOR_hex_byte ($key, "5c"); my $innerhash = hash_string($innerkey.$message); my $outerhash = hash_string($outerkey.$innerhash); return $outerhash; }; # XOR input with equally long string of repeated 2 hex character (byte) # string. Input must have even number of hex characters sub XOR_hex_byte # ($hex1, $hexbyte) -> $hex { my $hex1 = shift || ""; my $hexbyte = shift || ""; my $bytelength = length($hexbyte); my $hex2 = $hex1; $hex2 =~ s/.{$bytelength}/$hexbyte/ig; return XOR_hex_strings($hex1, $hex2); }; sub XOR_hex_strings # ($hex1, $hex2) -> $hex { my $hex1 = shift || ""; my $hex2 = shift || ""; my @hex1list = split('', $hex1); my @hex2list = split('', $hex2); my @hexresultlist = (); for(my $i; $i < scalar(@hex1list); ++$i) { my $d1 = hex($hex1list[$i]); my $d2 = hex($hex2list[$i]); my $dresult = ($d1 ^ $d2); $hexresultlist[$i] = sprintf("%x", $dresult); }; $hexresult = join('', @hexresultlist); return $hexresult; }; # End of Handle login access # # ############################################################################ # # Handle foreign interpreters (i.e., scripting languages) # # Insert perl code to execute scripts in foreign scripting languages. # Actually, the scripts inside the blocks are piped # into an interpreter. # The code presented here is fairly confusing because it # actually writes perl code code to the output. # # A table with the file handles %SCRIPTINGINPUT = (); # # A function to clean up Client delivered CGI parameter values # (i.e., quote all odd characters) %SHRUBcharacterTR = ( "\'" => ''', "\`" => '`', "\"" => '"', '&' => '&er;', "\\" => '\' ); sub shrubCGIparameter # ($String) -> Cleaned string { my $String = shift || ""; # Change all quotes [`'"] into HTML character entities my ($Char, $Transcript) = ('&', $SHRUBcharacterTR{'&'}); # Protect & $String =~ s/\Q$Char\E/$Transcript/isg if $Transcript; while( ($Char, $Transcript) = each %SHRUBcharacterTR) { next if $Char eq '&'; $String =~ s/\Q$Char\E/$Transcript/isg; }; # Replace newlines $String =~ s/[\n]/\\n/g; # Replace control characters with their backslashed octal ordinal numbers $String =~ s/([^\S \t])/(sprintf("\\0%o", ord($1)))/eisg; # $String =~ s/([\x00-\x08\x0A-\x1F])/(sprintf("\\0%o", ord($1)))/eisg; # return $String; }; # # The initial open statements: Open a pipe to the foreign script interpreter sub OpenForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; return $NewDirective if($SCRIPTINGINPUT{$ContentType}); # Construct a unique file handle name $SCRIPTINGFILEHANDLE = uc($ContentType); $SCRIPTINGFILEHANDLE =~ s/\W/\_/isg; $SCRIPTINGINPUT{$ContentType} = $SCRIPTINGFILEHANDLE unless $SCRIPTINGINPUT{$ContentType}; # Create the relevant script: Open the pipe to the interpreter $NewDirective .= <<"BLOCKCGISCRIPTOROPEN"; # Open interpreter for '$ContentType' # Open pipe to interpreter (if it isn't open already) open($SCRIPTINGINPUT{$ContentType}, "|$ScriptingLanguages{$ContentType}") || main::dieHandler(14, "$ContentType: \$!\\n"); BLOCKCGISCRIPTOROPEN # # Insert Initialization code and CGI variables $NewDirective .= InitializeForeignScript($ContentType); # Ready return $NewDirective; } # # The final closing code to stop the interpreter sub CloseForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; # Do nothing unless the pipe realy IS open return "" unless $SCRIPTINGINPUT{$ContentType}; # Initial comment $NewDirective .= "\# Close interpreter for '$ContentType'\n"; # # Write the Postfix code $NewDirective .= CleanupForeignScript($ContentType); # Create the relevant script: Close the pipe to the interpreter $NewDirective .= <<"BLOCKCGISCRIPTORCLOSE"; close($SCRIPTINGINPUT{$ContentType}) || main::dieHandler(15, \"$ContentType: \$!\\n\"); select(STDOUT); \$|=1; BLOCKCGISCRIPTORCLOSE # Remove the file handler of the foreign script delete($SCRIPTINGINPUT{$ContentType}); return $NewDirective; } # # The initialization code for the foreign script interpreter sub InitializeForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; # Add initialization code if($ScriptingInitialization{$ContentType}) { $NewDirective .= <<"BLOCKCGISCRIPTORINIT"; # Initialization Code for '$ContentType' # Select relevant output filehandle select($SCRIPTINGINPUT{$ContentType}); \$|=1; # # The Initialization code (if any) print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}INITIALIZATIONCODE'; $ScriptingInitialization{$ContentType} ${ContentType}INITIALIZATIONCODE BLOCKCGISCRIPTORINIT }; # Add all CGI variables defined if(exists($ScriptingCGIvariables{$ContentType})) { # Start writing variable definitions to the Interpreter if($ScriptingCGIvariables{$ContentType}) { $NewDirective .= <<"BLOCKCGISCRIPTORVARDEF"; # CGI variables (from the %default_values table) print $SCRIPTINGINPUT{$ContentType} << '${ContentType}CGIVARIABLES'; BLOCKCGISCRIPTORVARDEF }; my ($N, $V); foreach $N (keys(%default_values)) { # Determine whether the parameter has been defined # (the eval is a workaround to get at the variable value) next unless eval("defined(\$CGIexecute::$N)"); # Get the value from the EXECUTION environment $V = eval("\$CGIexecute::$N"); # protect control characters (i.e., convert them to \0.. form) $V = shrubCGIparameter($V); # Protect interpolated variables eval("\$CGIexecute::$N = '$V';") unless $ScriptingCGIvariables{$ContentType}; # Print the actual declaration for this scripting language if($ScriptingCGIvariables{$ContentType}) { $NewDirective .= sprintf($ScriptingCGIvariables{$ContentType}, $N, $V); $NewDirective .= "\n"; }; }; # Stop writing variable definitions to the Interpreter if($ScriptingCGIvariables{$ContentType}) { $NewDirective .= <<"BLOCKCGISCRIPTORVARDEFEND"; ${ContentType}CGIVARIABLES BLOCKCGISCRIPTORVARDEFEND }; }; # $NewDirective .= << "BLOCKCGISCRIPTOREND"; # Select STDOUT filehandle select(STDOUT); \$|=1; BLOCKCGISCRIPTOREND # return $NewDirective; }; # # The cleanup code for the foreign script interpreter sub CleanupForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; # Return if not needed return $NewDirective unless $ScriptingCleanup{$ContentType}; # Create the relevant script: Open the pipe to the interpreter $NewDirective .= <<"BLOCKCGISCRIPTORSTOP"; # Cleanup Code for '$ContentType' # Select relevant output filehandle select($SCRIPTINGINPUT{$ContentType}); \$|=1; # Print Cleanup code to foreign script print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}SCRIPTSTOP'; $ScriptingCleanup{$ContentType} ${ContentType}SCRIPTSTOP # Select STDOUT filehandle select(STDOUT); \$|=1; BLOCKCGISCRIPTORSTOP # return $NewDirective; }; # # The prefix code for each block sub PrefixForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; # Return if not needed return $NewDirective unless $ScriptingPrefix{$ContentType}; my $Quote = "\'"; # If the CGIvariables parameter is defined, but empty, interpolate # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END') $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) && !$ScriptingCGIvariables{$ContentType}; # Add initialization code $NewDirective .= <<"BLOCKCGISCRIPTORPREFIX"; # Prefix Code for '$ContentType' # Select relevant output filehandle select($SCRIPTINGINPUT{$ContentType}); \$|=1; # # The block Prefix code (if any) print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}PREFIXCODE$Quote; $ScriptingPrefix{$ContentType} ${ContentType}PREFIXCODE # Select STDOUT filehandle select(STDOUT); \$|=1; BLOCKCGISCRIPTORPREFIX # return $NewDirective; }; # # The postfix code for each block sub PostfixForeignScript # ($ContentType) -> $DirectivePrefix { my $ContentType = lc(shift) || return ""; my $NewDirective = ""; # Return if not needed return $NewDirective unless $ScriptingPostfix{$ContentType}; my $Quote = "\'"; # If the CGIvariables parameter is defined, but empty, interpolate # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END') $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) && !$ScriptingCGIvariables{$ContentType}; # Create the relevant script: Open the pipe to the interpreter $NewDirective .= <<"BLOCKCGISCRIPTORPOSTFIX"; # Postfix Code for '$ContentType' # Select filehandle to interpreter select($SCRIPTINGINPUT{$ContentType}); \$|=1; # Print postfix code to foreign script print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SCRIPTPOSTFIX$Quote; $ScriptingPostfix{$ContentType} ${ContentType}SCRIPTPOSTFIX # Select STDOUT filehandle select(STDOUT); \$|=1; BLOCKCGISCRIPTORPOSTFIX # return $NewDirective; }; sub InsertForeignScript # ($ContentType, $directive, @SRCfile) -> $NewDirective { my $ContentType = lc(shift) || return ""; my $directive = shift || return ""; my @SRCfile = @_; my $NewDirective = ""; my $Quote = "\'"; # If the CGIvariables parameter is defined, but empty, interpolate # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END') $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) && !$ScriptingCGIvariables{$ContentType}; # Create the relevant script $NewDirective .= <<"BLOCKCGISCRIPTORINSERT"; # Insert Code for '$ContentType' # Select filehandle to interpreter select($SCRIPTINGINPUT{$ContentType}); \$|=1; BLOCKCGISCRIPTORINSERT # Use SRC feature files my $ThisSRCfile; while($ThisSRCfile = shift(@_)) { # Handle blocks if($ThisSRCfile =~ /^\s*\{\s*/) { my $Block = $'; $Block = $` if $Block =~ /\s*\}\s*$/; $NewDirective .= <<"BLOCKCGISCRIPTORSRCBLOCK"; print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SRCBLOCKCODE$Quote; $Block ${ContentType}SRCBLOCKCODE BLOCKCGISCRIPTORSRCBLOCK next; }; # Handle files $NewDirective .= <<"BLOCKCGISCRIPTORSRCFILES"; # Read $ThisSRCfile open(SCRIPTINGSOURCE, "<$ThisSRCfile") || main::dieHandler(16, "$ThisSRCfILE: \$!"); while() { print $SCRIPTINGINPUT{$ContentType} \$_; }; close(SCRIPTINGSOURCE); BLOCKCGISCRIPTORSRCFILES }; # Add the directive if($directive) { $NewDirective .= <<"BLOCKCGISCRIPTORINSERT"; print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}DIRECTIVECODE$Quote; $directive ${ContentType}DIRECTIVECODE BLOCKCGISCRIPTORINSERT }; # $NewDirective .= <<"BLOCKCGISCRIPTORSELECT"; # Select STDOUT filehandle select(STDOUT); \$|=1; BLOCKCGISCRIPTORSELECT # Ready return $NewDirective; }; sub CloseAllForeignScripts # Call CloseForeignScript on all open scripts { my $ContentType; foreach $ContentType (keys(%SCRIPTINGINPUT)) { my $directive = CloseForeignScript($ContentType); print STDERR "\nDirective $CGI_Date: ", $directive; CGIexecute->evaluate($directive); }; }; # # End of handling foreign (external) scripting languages. # ############################################################################ # # A subroutine to handle "nested" quotes, it cuts off the leading # item or quoted substring # E.g., # ' A_word and more words' -> @('A_word', ' and more words') # '"quoted string" The rest' -> @('quoted string', ' The rest') # (this is needed for parsing the and their attributes) my $SupportedQuotes = "\'\"\`\(\{\["; my %QuotePairs = ('('=>')','['=>']','{'=>'}'); # Brackets sub ExtractQuotedItem # ($String) -> @($QuotedString, $RestOfString) { my @Result = (); my $String = shift || return @Result; if($String =~ /^\s*([\w\/\-\.]+)/is) { push(@Result, $1, $'); } elsif($String =~ /^\s*(\\?)([\Q$SupportedQuotes\E])/is) { my $BackSlash = $1 || ""; my $OpenQuote = $2; my $CloseQuote = $OpenQuote; $CloseQuote = $QuotePairs{$OpenQuote} if $QuotePairs{$OpenQuote}; if($BackSlash) { $String =~ /^\s*\\\Q$OpenQuote\E/i; my $Onset = $'; $Onset =~ /\\\Q$CloseQuote\E/i; my $Rest = $'; my $Item = $`; push(@Result, $Item, $Rest); } else { $String =~ /^\s*\Q$OpenQuote\E([^\Q$CloseQuote\E]*)\Q$CloseQuote\E/i; push(@Result, $1, $'); }; } else { push(@Result, "", $String); }; return @Result; }; # Now, start with the real work # # Control the output of the Content-type: text/html\n\n message my $SupressContentType = 0; # # Process a file sub ProcessFile # ($file_path) { my $file_path = shift || return 0; # # Generate a unique file handle (for recursions) my @SRClist = (); my $FileHandle = "file"; my $n = 0; while(!eof($FileHandle.$n)) {++$n;}; $FileHandle .= $n; # # Start HTML output # Use the default Content-type if this is NOT a raw file unless(($RawFilePattern && $ENV{'PATH_INFO'} =~ m@($RawFilePattern)$@i) || $SupressContentType) { $ENV{'PATH_INFO'} =~ m@($FilePattern)$@i; my $ContentType = $ContentTypeTable{$1}; print "Content-type: $ContentType\n"; if(%SETCOOKIELIST && keys(%SETCOOKIELIST)) { foreach my $name (keys(%SETCOOKIELIST)) { my $value = $SETCOOKIELIST{$name}; print "Set-Cookie: $name=$value\n"; }; # Cookies are set only ONCE %SETCOOKIELIST = (); }; print "\n"; $SupressContentType = 1; # Content type has been printed }; # # # Get access to the actual data. This can be from RAM (by way of an # environment variable) or by opening a file. # # Handle the use of RAM images (file-data is stored in the # $CGI_FILE_CONTENTS environment variable) # Note that this environment variable will be cleared, i.e., it is strictly for # single-use only! if($ENV{$CGI_FILE_CONTENTS}) { # File has been read already $_ = $ENV{$CGI_FILE_CONTENTS}; # Sorry, you have to do the reading yourself (dynamic document creation?) # NOTE: you must read the whole document at once if($_ eq '-') { $_ = eval("\@_=('$file_path'); do{$ENV{$CGI_DATA_ACCESS_CODE}}"); } else # Clear environment variable { $ENV{$CGI_FILE_CONTENTS} = '-'; }; } # Open Only PLAIN TEXT files (or STDIN) and NO executable files (i.e., scripts). # THIS IS A SECURITY FEATURE! elsif($file_path eq '-' || (-e "$file_path" && -r _ && -T _ && -f _ && ! (-x _ || -X _) )) { open($FileHandle, $file_path) || dieHandler(17, "File not found\n"); push(@OpenFiles, $file_path); $_ = <$FileHandle>; # Read first line } else { print "File not found\n"; dieHandler(18, "$file_path\n"); }; # $| = 1; # Flush output buffers # # Initialize variables my $METAarguments = ""; # The CGI arguments from the latest META tag my @METAvalues = (); # The ''-quoted CGI values from the latest META tag my $ClosedTag = 0; # versus # # Send document to output # Process the requested document. # Do a loop BEFORE reading input again (this catches the RAM/Database # type of documents). do { # # Handle translations if needed # performTranslation(\$_) if $TranslationPaths; # Catch tags # Do not process the content of end tag in $ENV{'PATH_INFO'}\n"); }; # # Process only when content should be executed if($CurrentContentType) { # # Remove all comments from Perl scripts # (NOT from OS shell scripts) $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g if $CurrentContentType =~ /$ServerScriptContentType/i; # # Convert SCRIPT calls, ./ or # . # # SAFEqx ONLY WORKS WHEN THE STRING ITSELF IS SURROUNDED BY SINGLE QUOTES # (SO THAT IT IS NOT INTERPOLATED BEFORE IT CAN BE PROTECTED) sub SAFEqx # ('String') -> result of executing qx/"String"/ { my $CommandString = shift; my $NewCommandString = ""; # # Only interpolate when required (check the On/Off switch) unless($CGIscriptor::NoShellScriptInterpolation) { # # Handle existing single quotes around CGI values while($CommandString =~ /\'[^\']+\'/s) { my $CurrentQuotedString = $&; $NewCommandString .= $`; $CommandString = $'; # The remaining string # Interpolate CGI variables between quotes # (e.g., '$CGIscriptorResults[-1]') $CurrentQuotedString =~ s/(^|[^\\])([\$\@])((\w*)([\{\[][\$\@\%]?[\:\w\-]+[\}\]])*)/if(exists($main::default_values{$4})){ "$1".eval("$2$3")}else{"$&"}/egs; # # Combine result with previous result $NewCommandString .= $CurrentQuotedString; }; $CommandString = $NewCommandString.$CommandString; # # Select known CGI variables and surround them with single quotes, # then interpolate all variables $CommandString =~ s/(^|[^\\])([\$\@\%]+)((\w*)([\{\[][\w\:\$\"\-]+[\}\]])*)/ if($2 eq '$' && exists($main::default_values{$4})) {"$1\'".eval("\$$3")."\'";} elsif($2 eq '@'){$1.join(' ', @{"$3"});} elsif($2 eq '%'){my $t=$1;map {$t.=" $_=".${"$3"}{$_}} keys(%{"$3"});$t} else{$1.eval("${2}$3"); }/egs; # # Remove backslashed [$@%] $CommandString =~ s/\\([\$\@\%])/$1/gs; }; # # Debugging # return $CommandString; # # Handle UNIX style "#! shell command\n" constructs as # a pipe into the shell command. The output cannot be tapped. my $ReturnValue = ""; if($CommandString =~ /^\s*\#\!([^\f\n\r]+)[\f\n\r]/is) { my $ShellScripts = $'; my $ShellCommand = $1; open(INTERPRETER, "|$ShellCommand") || dieHandler(29, "\'$ShellCommand\' PIPE not opened: &!\n"); select(INTERPRETER);$| = 1; print INTERPRETER $ShellScripts; close(INTERPRETER); select(STDOUT);$| = 1; } # Shell scripts which are redirected to an existing named pipe. # The output cannot be tapped. elsif($CGIscriptor::ShellScriptPIPE) { CGIscriptor::printSAFEqxPIPE($CommandString); } else # Plain ``-backtick execution { # Execute the commands $ReturnValue = qx/$CommandString/; }; return $ReturnValue; } #################################################################################### # # The CGIscriptor PACKAGE # #################################################################################### # # Isolate the evaluation of CGIscriptor functions, i.e., those prefixed with # "CGIscriptor::" # package CGIscriptor; # # The Interpolation On/Off switch my $NoShellScriptInterpolation = undef; # The ShellScript redirection pipe my $ShellScriptPIPE = undef; # # Open a named PIPE for SAFEqx to receive ALL shell scripts sub RedirectShellScript # ('CommandString') { my $CommandString = shift || undef; # if($CommandString) { $ShellScriptPIPE = "ShellScriptNamedPipe"; open($ShellScriptPIPE, "|$CommandString") || main::dieHandler(30, "\'|$CommandString\' PIPE open failed: $!\n"); } else { close($ShellScriptPIPE); $ShellScriptPIPE = undef; } return $ShellScriptPIPE; } # # Print to redirected shell script pipe sub printSAFEqxPIPE # ("String") -> print return value { my $String = shift || undef; # select($ShellScriptPIPE); $| = 1; my $returnvalue = print $ShellScriptPIPE ($String); select(STDOUT); $| = 1; # return $returnvalue; } # # a pointer to CGIexecute::SAFEqx sub SAFEqx # ('String') -> result of qx/"String"/ { my $CommandString = shift; return CGIexecute::SAFEqx($CommandString); } # # a pointer to CGIexecute::defineCGIvariable sub defineCGIvariable # ($name[, $default]) ->0/1 { my $name = shift; my $default = shift; return CGIexecute::defineCGIvariable($name, $default); } # # a pointer to CGIexecute::defineCGIvariable sub defineCGIvariableList # ($name[, $default]) ->0/1 { my $name = shift; my $default = shift; return CGIexecute::defineCGIvariableList($name, $default); } # # a pointer to CGIexecute::defineCGIvariable sub defineCGIvariableHash # ($name[, $default]) ->0/1 { my $name = shift; my $default = shift; return CGIexecute::defineCGIvariableHash($name, $default); } # # Decode URL encoded arguments sub URLdecode # (URL encoded input) -> string { my $output = ""; my $char; my $Value; foreach $Value (@_) { my $EncodedValue = $Value; # Do not change the loop variable # Convert all "+" to " " $EncodedValue =~ s/\+/ /g; # Convert all hexadecimal codes (%FF) to their byte values while($EncodedValue =~ /\%([0-9A-F]{2})/i) { $output .= $`.chr(hex($1)); $EncodedValue = $'; }; $output .= $EncodedValue; # The remaining part of $Value }; $output; }; # Encode arguments as URL codes. sub URLencode # (input) -> URL encoded string { my $output = ""; my $char; my $Value; foreach $Value (@_) { my @CharList = split('', $Value); foreach $char (@CharList) { if($char =~ /\s/) { $output .= "+";} elsif($char =~ /\w\-/) { $output .= $char;} else { $output .= uc(sprintf("%%%2.2x", ord($char))); }; }; }; $output; }; # Extract the value of a CGI variable from the URL-encoded $string # Also extracts the data blocks from a multipart request. Does NOT # decode the multipart blocks sub CGIparseValue # (ValueName [, URL_encoded_QueryString [, \$QueryReturnReference]]) -> Decoded value { my $ValueName = shift; my $QueryString = shift || $main::ENV{'QUERY_STRING'}; my $ReturnReference = shift || undef; my $output = ""; # if($QueryString =~ /(^|\&)$ValueName\=([^\&]*)(\&|$)/) { $output = URLdecode($2); $$ReturnReference = $' if ref($ReturnReference); } # Get multipart POST or PUT methods elsif($main::ENV{'CONTENT_TYPE'} =~ m@(multipart/([\w\-]+)\;\s+boundary\=([\S]+))@i) { my $MultipartType = $2; my $BoundaryString = $3; # Remove the boundary-string my $temp = $QueryString; $temp =~ /^\Q--$BoundaryString\E/m; $temp = $'; # # Identify the newline character(s), this is the first character in $temp my $NewLine = "\r\n"; # Actually, this IS the correct one unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure { # Is this correct??? I have to check. $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one) $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return }; # # search through all data blocks while($temp =~ /^\Q--$BoundaryString\E/m) { my $DataBlock = $`; $temp = $'; # Get the empty line after the header $DataBlock =~ /$NewLine$NewLine/; $Header = $`; $output = $'; my $Header = $`; $output = $'; # # Remove newlines from the header $Header =~ s/$NewLine/ /g; # # Look whether this block is the one you are looking for # Require the quotes! if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m) { my $i; for($i=length($NewLine); $i; --$i) { chop($output); }; # OK, get out last; }; # reinitialize the output $output = ""; }; $$ReturnReference = $temp if ref($ReturnReference); } elsif($QueryString !~ /(^|\&)$ValueName\=/) # The value simply isn't there { return undef; $$ReturnReference = undef if ref($ReturnReference); } else { print "ERROR: $ValueName $main::ENV{'CONTENT_TYPE'}\n"; }; return $output; } # # Get a list of values for the same ValueName. Uses CGIparseValue # sub CGIparseValueList # (ValueName [, URL_encoded_QueryString]) -> List of decoded values { my $ValueName = shift; my $QueryString = shift || $main::ENV{'QUERY_STRING'}; my @output = (); my $RestQueryString; my $Value; while($QueryString && (($Value = CGIparseValue($ValueName, $QueryString, \$RestQueryString)) || defined($Value))) { push(@output, $Value); $QueryString = $RestQueryString; # QueryString is consumed! }; # ready, return list with values return @output; } sub CGIparseValueHash # (ValueName [, URL_encoded_QueryString]) -> Hash table of decoded values { my $ValueName = shift; my $QueryString = shift || $main::ENV{'QUERY_STRING'}; my $RestQueryString; my %output = (); while($QueryString && $QueryString =~ /(^|\&)$ValueName([\w]*)\=/) { my $Key = $2; my $Value = CGIparseValue("$ValueName$Key", $QueryString, \$RestQueryString); $output{$Key} = $Value; $QueryString = $RestQueryString; # QueryString is consumed! }; # ready, return list with values return %output; } sub CGIparseForm # ([URL_encoded_QueryString]) -> Decoded Form (NO multipart) { my $QueryString = shift || $main::ENV{'QUERY_STRING'}; my $output = ""; # $QueryString =~ s/\&/\n/g; $output = URLdecode($QueryString); # $output; } # Extract the header of a multipart CGI variable from the POST input sub CGIparseHeader # (ValueName [, URL_encoded_QueryString]) -> Decoded value { my $ValueName = shift; my $QueryString = shift || $main::ENV{'QUERY_STRING'}; my $output = ""; # if($main::ENV{'CONTENT_TYPE'} =~ m@(multipart/([\w\-]+)\;\s+boundary\=([\S]+))@i) { my $MultipartType = $2; my $BoundaryString = $3; # Remove the boundary-string my $temp = $QueryString; $temp =~ /^\Q--$BoundaryString\E/m; $temp = $'; # # Identify the newline character(s), this is the first character in $temp my $NewLine = "\r\n"; # Actually, this IS the correct one unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure { $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one) $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double }; # # search through all data blocks while($temp =~ /^\Q--$BoundaryString\E/m) { my $DataBlock = $`; $temp = $'; # Get the empty line after the header $DataBlock =~ /$NewLine$NewLine/; $Header = $`; my $Header = $`; # # Remove newlines from the header $Header =~ s/$NewLine/ /g; # # Look whether this block is the one you are looking for # Require the quotes! if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m) { $output = $Header; last; }; # reinitialize the output $output = ""; }; }; return $output; } # # Checking variables for security (e.g., file names and email addresses) # File names are tested against the $::FileAllowedChars and $::BlockPathAccess variables sub CGIsafeFileName # FileName -> FileName or "" { my $FileName = shift || ""; return "" if $FileName =~ m?[^$::FileAllowedChars]?; return "" if $FileName =~ m!(^|/|\:)[\-\.]!; return "" if $FileName =~ m@\.\.\Q$::DirectorySeparator\E@; # Higher directory not allowed return "" if $FileName =~ m@\Q$::DirectorySeparator\E\.\.@; # Higher directory not allowed return "" if $::BlockPathAccess && $FileName =~ m@$::BlockPathAccess@; # Invisible (blocked) file return $FileName; } sub CGIsafeEmailAddress # email -> email or "" { my $Email = shift || ""; return "" unless $Email =~ m/^[\w\.\-]+[\@][\w\.\-\:]+$/; return $Email; } # Get a URL from the web. Needs main::GET_URL($URL) function # (i.e., curl, snarf, or wget) sub read_url # ($URL) -> page/file { my $URL = shift || return ""; # Get the commands to read the URL, do NOT add a print command my $URL_command = main::GET_URL($URL, 1); # execute the commands, i.e., actually read it my $URLcontent = CGIexecute->evaluate($URL_command); # Ready, return the content. return $URLcontent; }; ################################################>>>>>>>>>>Start Remove # # BrowseAllDirs(Directory, indexfile) # # usage: # # # Allows to browse all directories. Stops at '/'. If the directory contains # an indexfile, eg, index.html, that file will be used instead. Files must match # the $Pattern, if it is given. Default is # CGIscriptor::BrowseAllDirs('/', 'index.html', '') # sub BrowseAllDirs # (Directory, indexfile, $Pattern) -> Print HTML code { my $Directory = shift || '/'; my $indexfile = shift || 'index.html'; my $Pattern = shift || ''; $Directory =~ s!/$!!g; # If the index directory exists, use that one if(-s "$::CGI_HOME$Directory/$indexfile") { return main::ProcessFile("$::CGI_HOME$Directory/$indexfile"); }; # No indexfile, continue my @DirectoryList = glob("$::CGI_HOME$Directory"); $CurrentDirectory = shift(@DirectoryList); $CurrentDirectory = $' if $CurrentDirectory =~ m@(/\.\./)+@; $CurrentDirectory =~ s@^$::CGI_HOME@@g; print ""; print "$CurrentDirectory" if $CurrentDirectory; print "\n"; opendir(BROWSE, "$::CGI_HOME$Directory") || main::dieHandler(31, "$::CGI_HOME$Directory $!"); my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE)); # # Print directories my $file; print "\n"; foreach $file (@AllFiles) { next unless -d "$::CGI_HOME$Directory/$file"; # Check whether this file should be visible next if $::BlockPathAccess && "$Directory/$file/" =~ m@$::BlockPathAccess@; print "$file\n"; }; print "\n"; # # Print files print "\n"; my $TotalSize = 0; foreach $file (@AllFiles) { next if $file =~ /^\./; next if -d "$::CGI_HOME$Directory/$file"; next if -l "$::CGI_HOME$Directory/$file"; # Check whether this file should be visible next if $::BlockPathAccess && "$Directory/$file" =~ m@$::BlockPathAccess@; if(!$Pattern || $file =~ m@$Pattern@) { my $Date = localtime($^T - (-M "$::CGI_HOME$Directory/$file")*3600*24); my $Size = -s "$::CGI_HOME$Directory/$file"; $Size = sprintf("%6.0F kB", $Size/1024); my $Type = `file $::CGI_HOME$Directory/$file`; $Type =~ s@\s*$::CGI_HOME$Directory/$file\s*\:\s*@@ig; chomp($Type); print ""; print ""; printf("%-40s", "$file"); print "\t$Size\t$Date\t$Type"; print "\n"; }; }; print ""; # return 1; }; ################################################ # # BrowseDirs(RootDirectory [, Pattern, Start]) # # usage: # # # Allows to browse subdirectories. Start should be relative to the RootDirectory, # e.g., the full path of the directory 'Speech' is '~/Sounds/Speech'. # Only files which fit /$Pattern/ and directories are displayed. # Directories down or up the directory tree are supplied with a # GET request with the name of the CGI variable in the fourth argument (default # is 'BROWSEDIRS'). So the correct call for a subdirectory could be: # CGIscriptor::BrowseDirs('Sounds', '\.aifc$', $DIRECTORY, 'DIRECTORY') # sub BrowseDirs # (RootDirectory [, Pattern, Start, CGIvariable, HTTPserver]) -> Print HTML code { my $RootDirectory = shift; # || return 0; my $Pattern = shift || '\S'; my $Start = shift || ""; my $CGIvariable = shift || "BROWSEDIRS"; my $HTTPserver = shift || ''; # $Start = CGIscriptor::URLdecode($Start); # Sometimes, too much has been encoded $Start =~ s@//+@/@g; $Start =~ s@[^/]+/\.\.@@ig; $Start =~ s@^\.\.@@ig; $Start =~ s@/\.$@@ig; $Start =~ s!/+$!!g; $Start .= "/" if $Start; # my @Directory = glob("$::CGI_HOME/$RootDirectory/$Start"); $CurrentDirectory = shift(@Directory); $CurrentDirectory = $' if $CurrentDirectory =~ m@(/\.\./)+@; $CurrentDirectory =~ s@^$::CGI_HOME@@g; print ""; print "$CurrentDirectory" if $CurrentDirectory; print "\n"; opendir(BROWSE, "$::CGI_HOME/$RootDirectory/$Start") || main::dieHandler(31, "$::CGI_HOME/$RootDirectory/$Start $!"); my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE)); # # Print directories my $file; print "\n"; foreach $file (@AllFiles) { next unless -d "$::CGI_HOME/$RootDirectory/$Start$file"; # Check whether this file should be visible next if $::BlockPathAccess && "/$RootDirectory/$Start$file/" =~ m@$::BlockPathAccess@; my $NewURL = $Start ? "$Start$file" : $file; $NewURL = CGIscriptor::URLencode($NewURL); print "$file\n"; }; print "\n"; # # Print files print "\n"; my $TotalSize = 0; foreach $file (@AllFiles) { next if $file =~ /^\./; next if -d "$::CGI_HOME/$RootDirectory/$Start$file"; next if -l "$::CGI_HOME/$RootDirectory/$Start$file"; # Check whether this file should be visible next if $::BlockPathAccess && "$::CGI_HOME/$RootDirectory/$Start$file" =~ m@$::BlockPathAccess@; if($file =~ m@$Pattern@) { my $Date = localtime($^T - (-M "$::CGI_HOME/$RootDirectory/$Start$file")*3600*24); my $Size = -s "$::CGI_HOME/$RootDirectory/$Start$file"; $Size = sprintf("%6.0F kB", $Size/1024); my $Type = `file $::CGI_HOME/$RootDirectory/$Start$file`; $Type =~ s@\s*$::CGI_HOME/$RootDirectory/$Start$file\s*\:\s*@@ig; chomp($Type); print ""; if($HTTPserver =~ /^\s*[\.\~]\s*$/) { print ""; } elsif($HTTPserver) { print ""; }; printf("%-40s", "$file") if $HTTPserver; printf("%-40s", "$file") unless $HTTPserver; print "\t$Size\t$Date\t$Type"; print "\n"; }; }; print ""; # return 1; }; # # ListDocs(Pattern [,ListType]) # # usage: # # # This subroutine is very usefull to manage collections of independent # documents. The resulting list will display the tree-like directory # structure. If this routine is too slow for online use, you can # store the result and use a link to that stored file. # # List HTML and Text files with title and first header (HTML) # or filename and first meaningfull line (general text files). # The listing starts at the ServerRoot directory. Directories are # listed recursively. # # You can change the list type (default is dl). # e.g., # >title # First Header # >file.txt # First meaningfull line of text # sub ListDocs # ($Pattern [, prefix]) e.g., ("/Books/*", [, "dl"]) { my $Pattern = shift; $Pattern =~ /\*/; my $ListType = shift || "dl"; my $Prefix = lc($ListType) eq "dl" ? "dt" : "li"; my $URL_root = "http://$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}"; my @FileList = glob("$::CGI_HOME$Pattern"); my ($FileName, $Path, $Link); # # Print List markers print "<$ListType>\n"; # # Glob all files File: foreach $FileName (@FileList) { # Check whether this file should be visible next if $::BlockPathAccess && $FileName =~ m@$::BlockPathAccess@; # Recursively list files in all directories if(-d $FileName) { $FileName =~ m@([^/]*)$@; my $DirName = $1; print "<$Prefix>$DirName\n"; $Pattern =~ m@([^/]*)$@; &ListDocs("$`$DirName/$1", $ListType); next; } # Use textfiles elsif(-T "$FileName") { open(TextFile, $FileName) || next; } # Ignore all other file types else { next;}; # # Get file path for link $FileName =~ /$::CGI_HOME/; print "<$Prefix>"; # Initialize all variables my $Line = ""; my $TitleFound = 0; my $Caption = ""; my $Title = ""; # Read file and step through while() { chop $_; $Line = $_; # HTML files if($FileName =~ /\.ht[a-zA-Z]*$/i) { # Catch Title while(!$Title) { if($Line =~ m@([^<]*)@i) { $Title = $1; $Line = $'; } else { $Line .= || goto Print; chop $Line; }; }; # Catch First Header while(!$Caption) { if($Line =~ m@@i) { $Caption = $`; $Line = $'; $Caption =~ m@@i; $Caption = $'; $Line = $`.$Caption.$Line; } else { $Line .= || goto Print; chop $Line; }; }; } # Other text files else { # Title equals file name $FileName =~ /([^\/]+)$/; $Title = $1; # Catch equals First Meaningfull line while(!$Caption) { if($Line =~ /[A-Z]/ && ($Line =~ /subject|title/i || $Line =~ /^[\w,\.\s\?\:]+$/) && $Line !~ /Newsgroup/ && $Line !~ /\:\s*$/) { $Line =~ s/\<[^\>]+\>//g; $Caption = $Line; } else { $Line = || goto Print; }; }; }; Print: # Print title and subject print "$Title\n"; print "$Caption\n" if $ListType eq "dl"; $TitleFound = 0; $Caption = ""; close TextFile; next File; }; }; # Print Closing List Marker print "\n"; ""; # Empty return value }; # # HTMLdocTree(Pattern [,ListType]) # # usage: # # # The following subroutine is very usefull for checking large document # trees. Starting from the root (s), it reads all files and prints out # a nested list of links to all attached files. Non-existing or misplaced # files are flagged. This is quite a file-i/o intensive routine # so you would not like it to be accessible to everyone. If you want to # use the result, save the whole resulting page to disk and use a link # to this file. # # HTMLdocTree takes an HTML file or file pattern and constructs nested lists # with links to *local* files (i.e., only links to the local server are # followed). The list entries are the document titles. # If the list type is , the first header is used too. # For each file matching the pattern, a list is made recursively of all # HTML documents that are linked from it and are stored in the same directory # or a sub-directory. Warnings are given for missing files. # The listing starts for the ServerRoot directory. # You can change the default list type (, , ). # %LinkUsed = (); sub HTMLdocTree # ($Pattern [, listtype]) # e.g., ("/Welcome.html", [, "ul"]) { my $Pattern = shift; my $ListType = shift || "dl"; my $Prefix = lc($ListType) eq "dl" ? "dt" : "li"; my $URL_root = "http://$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}"; my ($Filename, $Path, $Link); my %LocalLinks = {}; # # Read files (glob them for expansion of wildcards) my @FileList = glob("$::CGI_HOME$Pattern"); foreach $Path (@FileList) { # Get URL_path $Path =~ /$::CGI_HOME/; my $URL_path = $'; # Check whether this file should be visible next if $::BlockPathAccess && $URL_path =~ m@$::BlockPathAccess@; my $Title = $URL_path; my $Caption = ""; # Current file should not be used again ++$LinkUsed{$URL_path}; # Open HTML doc unless(open(TextFile, $Path)) { print "<$Prefix>$Title (not found) \n"; next; }; while() { chop $_; $Line = $_; # Catch Title while($Line =~ m@@i) { if($Line =~ m@<title>([^<]*)@i) { $Title = $1; $Line = $'; } else { $Line .= ; chop $Line; }; }; # Catch First Header while(!$Caption && $Line =~ m@@i) { if($Line =~ m@@i) { $Caption = $`; $Line = $'; $Caption =~ m@ @i; $Caption = $'; $Line = $`.$Caption.$Line; } else { $Line .= ; chop $Line; }; }; # Catch and print Links while($Line =~ m@]*)>@i) { $Link = $1; $Line = $'; # Remove quotes $Link =~ s/\"//g; # Remove extras $Link =~ s/[\#\?].*$//g; # Remove Servername if($Link =~ m@(http://|^)@i) { $Link = $'; # Only build tree for current server next unless $Link =~ m@$::ENV{'SERVER_NAME'}|^/@; # Remove server name and port $Link =~ s@^[^\/]*@@g; # # Store the current link next if $LinkUsed{$Link} || $Link eq $URL_path; ++$LinkUsed{$Link}; ++$LocalLinks{$Link}; }; }; }; close TextFile; print "<$Prefix>"; print ""; print "$Title\n"; print " $Caption\n" if $Caption && $Caption ne $Title && $ListType =~ /dl/i; print "<$ListType>\n"; foreach $Link (keys(%LocalLinks)) { &HTMLdocTree($Link, $ListType); }; print "\n"; }; }; ###########################<<<<<<<<<

"Hello World"

# AnswerQuestion($Question); #

What is the capital of the Netherlands?

Amsterdam

File not found

File not found

"; print "$CurrentDirectory" if $CurrentDirectory; print "

"; print "$CurrentDirectory" if $CurrentDirectory; print "

@i) { if($Line =~ m@@i) { $Caption = $`; $Line = $'; $Caption =~ m@