#!MUNGERPATH

; Munger Copyright (c) 2001-2007, James Bailie.
; All rights reserved.
;
; Redistribution and use in source form, with or without
; modification, is permitted provided that the following conditions are met:
;
;     * Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;     * The name of James Bailie may not be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

; -----------------------------------------------------------------------

; This script is a minimal HTTP/1.1 server, using a pre-fork multi-process
; model.  It understands the GET, HEAD and POST requests.  It is intended
; to serve as a complete example of how to write a non-trivial server in
; Munger.  It is NOT intended for real-world use as a web server.  It does
; not fully conform to HTTP/1.1.

; The program must be run as root to bind to port 80.

; To stop the server issue the following command.

; kill -TERM `cat /var/run/httpd.munger.pid`

; ------------------------------------

; The root document must reside in the directory named by the -h option,
; and be named "index.html".

; Seven options may be given to the server at startup:

; -n

; This option specifies the number of idle slave servers the master server
; will attempt to keep running.  It defaults to 10.  The number of idle
; slaves is regularly adjusted while the server is runing.  If more or less
; than the specified number of slaves are idle, then slaves will be killed
; or forked as necessary in an attempt to maintain this number of idle
; slaves.  This behavior combats the, "thundering herd," problem to which
; multi-process servers are prone.

; -m

; This option specifies the maximum allowable number of slave servers
; which can be alive at any time.  It defaults to 75.  This setting will
; will be automatically changed to the value of the -n option, or that
; option's default value, if that value is greater than the value given to
; -m.

; -r

; This option specifies the server root directory.  It should not have a
; trailing slash.  This defaults to "/usr/local/www".

; -h

; This option specifies the subdirectory of the server root where your
; static files (HTML, CSS, etc.) reside.  It should not have a leading nor
; a trailing slash.  This value defaults to "html".

; -d

; This option specifies the subdirectory of the server root where CGI
; programs reside.  It should not have a leading nor trailing slash.  This
; value defaults to "cgi-bin".

; -u
; -g

; These options are used to set the user and group the server will run as.
; This user and group must have appropriate permissions to the directories
; specified by the -r, -h, and -d options, as well as to the files which
; reside in those directories.

; -----------------------------------------------------------------------

; Makes errors fatal to interpreter.

(fatal)

; The master process must run as root to bind to the socket and to
; write pid files.

(when (cadr (geteuid))
   (die "httpd.munger must start as root."))

; Allow zombies, so we can "wait" for CGI programs and know when
; server children expire.

(zombies)

; List of hostnames which may appear in request Host: header. ie., (setq
; hostnames "www.mammothcheese.ca" "mammothcheese.ca") Make sure you don't
; accidentally change hostnames to hostname.  This list will be ignored if
; a request does not have a Host: header.  The first name on the list will
; be propagated to CGI programs via the SERVER_NAME environment variable.

(setq hostnames '("127.0.0.1"))

; Where to listen for connections.

(setq interface "127.0.0.1")
(setq port 80)

; Document returned when / is requested.

(setq root_doc "index.html")

; Where the httpd.munger.pid file will be written.

(setq piddir "/var/run/")

; Get the user-supplied options.

(load (join "/" (libdir) "options.munger"))
(getopt)

; User and group to run as.

(if (setq n (lookup options "u"))
   (setq user n)
   (setq user "www"))

(if (setq n (lookup options "g"))
   (setq group n)
   (setq group "www"))

; The number of servers to fork.

(if (and (setq n (lookup options "n")) (setq n (digitize n)))
   (setq num_servers n)
   (setq num_servers 10))

; The maximum number of servers which may be alive at any time.

(if (and (setq n (lookup options "m")) (setq n (digitize n)))
   (setq max_servers n)
   (setq max_servers 75))

; Server root directory.  The server will chdir here.  No trailing slash.

(if (setq n (lookup options "r"))
   (setq server_root n)
   (setq server_root "/usr/local/www/drood"))

; The subdirectory of server_root where HTML files live.  No
; leading or trailing slashes.

(if (setq n (lookup options "h"))
   (setq static_root n)
   (setq static_root "mammothcheese.ca"))

; The subdirectory of server_root where CGI programs live.  No
; leading or trailing slashes.

(if (setq n (lookup options "d"))
   (setq cgi_root n)
   (setq cgi_root "cgi-bin"))

; Start listening.

(when (stringp (setq result (listen port interface)))
   (die result))

; Detach ourselves from terminal.

(daemonize "httpd.munger")

; Alist mapping server number to child pid, total number of running slaves,
; highest server number allocated, and list of reclaimed server numbers
; from dead slaves.

(setq pids ())
(setq running num_servers)
(setq nextnum num_servers)
(setq reclaimed ())

; Create busymap so slaves can communicate their status to master.  Must
; be created before we fork any slaves.

(when (stringp (setq tmp (busymap max_servers)))
   (die "could not create busymap: " tmp))

; Function to fork server children.

(defun fork_server ()

   (cond ((< (setq pid (fork)) 0)
          (syslog 'ERROR "couldn't fork child.")
          (exit 1))

         (pid 1)

         (1 pid)))

; Function to find the server number from a pid in the pids alist.

(defun find_number (pid)
   (setq tmp pids)

   (while (and tmp (not (eq pid (cadr (car tmp)))))
      (setq tmp (cdr tmp)))

   (if tmp
      (caar tmp)
      0))

; Function to reap zombie slaves.  We update alist of server numbers and
; pids, number of running slaves, number of idle slaves, and add server
; numbers to the reclaimed list.  We also remove the now-stale pid file for
; the slave.

(defun reap_zombies ()
   (while (> (car (setq tmp (wait -1 1))) 0)
      (when (setq result (find_number (car tmp)))
         (notbusy (- result 1))
         (dec running)
         (setq reclaimed (cons result reclaimed))
         (setq pids (alist_remove result pids)))))

; Function to determine how many idle slaves there are.

(defun count_idle ()
   (setq tmp pids)
   (setq idle 0)

   (while tmp
      (inc idle (not (busyp (- (caar tmp) 1))))
      (setq tmp (cdr tmp))))

; Function to kill a single idle slave, if necessary.  A race condition
; exists between the call of count_idle and this function.  More or less
; slaves may be idle now than were counted.  If there are more idle, we'll
; kill another during a future invocation, if it's still idle then.  If
; there are less idle, then we will kill one more than we should.  That
; will be corrected when fork_more is invoked.

(defun kill_excess ()
   (catch
      (when (> idle num_servers)
         (for (n 1 nextnum)

            ; Test to see if the slave is not busy and it actually exists
            ; before doing anything.  Slaves which have died will have
            ; created holes in the busymap.  Only those on the pids alist
            ; are really alive.

            (and (setq tmp (alist_lookup n pids))
                 (not (busyp (- n 1)))
                 (kill (car tmp) 15)
                 (throw (dec idle)))))))

; Function to fork slaves as necessary.

(let ((half (or (/ num_servers 2) 1)))

   (defun fork_more ()
      (while (and (< running max_servers) (< idle half)
                  (or reclaimed (< nextnum (- max_servers 1))))
   
         (if (fork_server)
            (progn
   
               ; Update vars accordingly in parent.
   
               (inc running)
               (inc idle)
   
               (if (not reclaimed)
                  (setq pids (alist_replace (inc nextnum) pids (list pid)))
                  (setq pids (alist_replace (car reclaimed) pids (list pid)))
                  (setq reclaimed (cdr reclaimed))))
   
            ; Child sets itself notbusy in busymap, and throws itself out of
            ; the toplevel loop of this function's caller.
   
            (setq result (if reclaimed (car reclaimed) (inc nextnum)))
            (notbusy (- result 1))
            (throw 0)))))

; Fork-off initial num_servers slaves.  Assigns 0 to result in parent, and
; server number to result in child.  The server number is used to specify a
; slave's entry in the busymap.

(setq result
   (catch
      (for (n 1 num_servers)
         (if (fork_server)
            (setq pids (alist_replace n pids (list pid)))
            (notbusy (- n 1))
            (throw n)))

      0))

; Parent stops here to becomes master server.  Children continue on to
; become slaves.

(unless result

   ; Master pid file.

   (with_output_file (join "/" piddir "httpd.munger.pid") (println (getpid)))

   ; Loops here forever as root, managing the number of idle servers.

   (catch
      (loop
         (sleep 1)

         (when (sigtermp)
            (while pids
               (kill (car (cdar pids)) 15)
               (setq pids (cdr pids)))

            (syslog 'ERROR "Quitting on SIGTERM")
            (quit))

         (count_idle)
         (kill_excess)
         (reap_zombies)
         (fork_more))))

; Result is set to slave's server number.

(setq busy_idx (- result 1))

; chdir to the document server_root directory.

(when (stringp (setq result (chdir server_root)))
   (syslog 'ERROR (concat "could not chdir to " server_root ": " result))
   (exit 1))

; Become a member of the configured group.

(when (stringp (setq result (setgid group)))
   (die "Could not join group " group ": " result))

; Become a less-privileged user.  We must do this after writing our pid
; file, because we need to be root to gain access to /var/run.

(when (stringp (setuid user))
   (syslog 'ERROR (concat "could not change to user " user))
   (exit 1))

; Regexps used to pluck out items from requests.  There is no better way
; to slow down a server than to use regexps.  Better by far for performance
; to downcase and eq strings, or to explode strings into lists and parse them,
; but this is an example program.  We take the easy way out.

(when (stringp (setq get_rx (regcomp "^(GET|HEAD|POST)[\b\t]+([^\b\t]+)[\b\t]+HTTP/1\.([01])" 1)))
   (syslog 'ERROR (concat "regcomp: " get_rx))
   (exit 1))

(when (stringp (setq root_rx (regcomp server_root 0 1)))
   (syslog 'ERROR (concat "regcomp: " root_rx))
   (exit 1))

(when (stringp (setq suffix_rx (regcomp "\.[^.\b\t]+$")))
   (syslog 'ERROR (concat "regcomp: " suffix_rx))
   (exit 1))

(when (stringp (setq cgi_rx (regcomp (concat "^/" cgi_root "/"))))
   (syslog 'ERROR (concat "regcomp: " cgi_rx))
   (exit 1))

(when (stringp (setq close_rx (regcomp "^Connection:\b+close" 1)))
   (syslog 'ERROR (concat "regcomp: " close_rx))
   (exit 1))

(when (stringp (setq parent_rx (regcomp "(^|/)\.\./")))
   (syslog 'ERROR (concat "regcomp: " parent_rx))
   (exit 1))

(when (stringp (setq length_rx (regcomp "^Content-Length:\b+([0-9]+)" 1)))
   (syslog 'ERROR (concat "regcomp: " length_rx))
   (exit 1))

(when (stringp (setq agent_rx (regcomp "^User-Agent:\b+(.*)" 1)))
   (syslog 'ERROR (concat "regcomp: " agent_rx))
   (exit 1))

(when (stringp (setq cookie_rx (regcomp "^Cookie:\b+(.*)" 1)))
   (syslog 'ERROR (concat "regcomp: " cookie_rx))
   (exit 1))

(when (stringp (setq expect_rx (regcomp "^Expect:\b+100-continue" 1)))
   (syslog 'ERROR (concat "regcomp: " expect_rx))
   (exit 1))

(when (stringp (setq location_rx (regcomp "^Location:" 1)))
   (syslog 'ERROR (concat "regcomp: " location_rx))
   (exit 1))

(when (stringp (setq date_rx (regcomp "^Date:" 1)))
   (syslog 'ERROR (concat "regcomp: " date_rx))
   (exit 1))

(when (stringp (setq host_rx (regcomp "^Host:\b+([\b\t]+)" 1)))
   (syslog 'ERROR (concat "regcomp: " host_rx))
   (exit 1))

; The file types we recognize by suffix.

(setq types
   '((".gif" "image/gif") (".jpg" "image/jpeg") (".jpeg" "image/jpeg")
     (".png" "image/png") (".html" "text/html") (".css" "text/css")
     (".gz"  "application/x-gzip") (".tgz" "application/x-gzip")
     (".js"  "application/x-javascript")))

; Version of interpreter.  Used in Server: response headers.

(setq ver (version))

; Utility functions.

(defun send_common_headers ((need_date))
   (println "Server: httpd.munger/1.0 Munger/"
      (car ver) "." (cadr ver)
      " (http://www.mammothcheese.ca/)" (char 13))
   (when (or (not need_date) (car need_date))
      (println "Date: " (date 1 1) (char 13))))

(defun error (msg)
   (setq close 1)
   (println msg (char 13))
   (send_common_headers)
   (println "Connection: close" (char 13))
   (println "Content-Type: text/html" (char 13))
   (println "Content-Length: " (+ 70 (length msg)) (char 13))
   (println (char 13))
   (println "<html><head><title>Error</title></head><body><h1>" msg "</h1>"
      "</body></html>" (char 13)))

; Function to chunk and send a response body from a CGI program to a
; client.

(defun send_chunked_body ()
   (setq block "")
   (setq blocksize (dec2hex 8192))

   (while (and (stringp (setq block (getchars 8192 10)))
               (eq (setq len (length block)) 8192))
      (println blocksize (char 13))
      (print block)
      (println (char 13)))

   (when block
      (println (dec2hex (length block)) (char 13))
      (print block)
      (println (char 13)))

   (println "0" (char 13))
   (println (char 13)))

; Function to send a CGI program's response to the client, after the
; request header has been examined and supplemented as necessary.

(defun send_response ()

         ; If the response is to an HTTP/1.0 request send the CGI program's
         ; headers and the request body as is.

   (cond ((eq status "HTTP/1.0 200 OK")
          (foreach (lambda (x) (println x (char 13))) (reverse headers))
          (println (char 13))
          (while (setq line (getchars 100000))
             (print line)))

         ; If the response is to an HTTP/1.1 request send the CGI program's
         ; headers and the request body unchunked if the CGI program
         ; generated a Content-Length header, or chunked, otherwise.

         ((eq status "HTTP/1.1 200 OK")
          (unless content_length
             (println "Transfer-Encoding: chunked" (char 13)))
          (foreach (lambda (x) (println x (char 13))) (reverse headers))
          (println (char 13))

          (if (not content_length)
             (send_chunked_body)

             (while (setq line (getchars 100000))
                (print line))))

         ; If the response is a redirect, send the CGI program's headers
         ; only.

         (1 (foreach (lambda (x) (println x (char 13))) (reverse headers))
            (println (char 13)))))

; Function to examine the header of a CGI program response, add appropriate
; status line, and begin the response to the client.  We check for
; redirections with the Location: header, and add a Date: header, if it's
; missing.  We also make sure the each line in the response header is
; terminated with both a carriage return and newline.  It is assumed the
; CGI program will spit out the Content-Type header and the header/body
; separator line at the very least, as well as the response body.  We
; chunk the response body for HTTP/1.1 requests, unless the CGI program
; generated a Content-Length header.

(defun filter_cgi_response ()
   (setq headers ())
   (setq content_length "")
   (setq need_date 1)
   (setq status (concat "HTTP/1." (cadddr request) " 200 OK"))

   ; Parse the response header

   (while (and (setq line (getline_ub 5)) (setq line (chomp line)))
      (cond ((match location_rx line)
             (setq close 1)
             (setq status (concat "HTTP/1." (cadddr request) " 302 Found")))

            ((match date_rx line)
             (setq need_date 0))

            ((setq m (matches length_rx line))
             (setq content_length (cadr m))))

      (setq headers (cons line headers)))

   ; Premature end of headers results in an error.

   (if (eq line 0)
      (error (concat "HTTP/1." (cadddr request) " 500 internal server error"))

      ; Send the appropriate status line to the client and the beginning of
      ; the response headers.

      (println status (char 13))
      (send_common_headers need_date)
      (when close
         (println "Connection: close" (char 13)))

      (send_response)

      ; Close the pipe to the CGI program and reap its zombie.

      (resume 0)
      (wait pid)))

; Function to fork CGI program.  We forkpipe, redirecting the CGI program's
; stdout onto the pipe, while letting the program inherit the socket
; descriptor on its stdin.  This allows us to filter the program's output.

(defun fork_cgi ()
   (cond ((< (setq pid (forkpipe 0)) 0)
          (error "HTTP/1.1 500 internal server error"))

         (pid (filter_cgi_response))

         (1 (nobusymap)
            (eval do_env)
            (eval do_length)

            ; exec returns a string describing an error condition on
            ; failure.

            (syslog 'ERROR (exec (car cgi)))
            (exit 1))))

; Function to prepare environment to launch a CGI program.

(defun launch_cgi ()
   (setq cgi (split "?" (join "/" server_root file)))

   (cond ((not (setq tmp (exists (car cgi))))
          (error "HTTP/1.1 404 not found"))

         ; We don't allow CGI programs to be symbolic links.

         ((or (not (eq tmp 1))
              (not (access (car cgi) 0))
              (not (access (car cgi) 2)))
          (error "HTTP/1.1 403 forbidden"))

            ; We will evaluate this expression to set-up the environment,
            ; in the child process, to avoid the memory leak described in
            ; setenv(2) occuring in the parent.

         (1 (setq do_env
               (qquote
                  (progn
                     (setenv "QUERY_STRING" ,(if (cdr cgi) (cadr cgi) ""))
                     (setenv "REQUEST_METHOD" ,(cadr request))
                     (setenv "HTTP_USER_AGENT" ,agent)
                     (setenv "REMOTE_ADDR" ,(or (getpeername) ""))
                     (setenv "SERVER_SOFTWARE" "httpd.munger")
                     (setenv "SERVER_NAME" ,(car hostnames))
                     (setenv "GATEWAY_INTERFACE" "CGI/1.1")
                     (setenv "SCRIPT_NAME" ,(substitute root_rx "" (car cgi) 1))
                     (setenv "HTTP_COOKIE" ,cookie))))

            (cond ((eq "GET" (cadr request))
                   (setq do_length
                     (qquote
                        (setenv "CONTENT_LENGTH"
                           ,(stringify
                              (length (if (cdr cgi) (cadr cgi) ""))))))
                   (fork_cgi))

                  ((eq "HEAD" (cadr request))
                   (println "HTTP/1.1 200 OK" (char 13))
                   (send_common_headers)
                   (println (char 13)))

                  ((eq "POST" (cadr request))
                   (if (not content_length)
                      (error "HTTP/1.1 411 length required")

                      (setq do_length
                        (qquote
                            (setenv "CONTENT_LENGTH" ,content_length)))

                     (when expect_100
                        (println "HTTP/1.1 100 continue" (char 13))
                        (println (char 13))
                        (flush_stdout))

                      (fork_cgi)))))))

; Function to generate responses to requests.

(defun process_request ()

   ; If the initial path to the requested resource is cgi_root, we have
   ; a dynamic request.  Otherwise we have static request.

   (cond ((match cgi_rx file) (launch_cgi))

         ((not (setq size
            (stat (setq file (join "/" server_root static_root file)))))
          (error "HTTP/1.1 404 not found"))

         ; If the file is not a regular file nor a symbolic link, or we can't
         ; read it, the client is forbidden to receive it.

         ((not (and (or (eq 6 (setq tmp (exists file))) (eq 1 tmp))
                    (access file 0)))
          (error "HTTP/1.1 403 forbidden"))

         ; Spit out the response, generating an appropriate Content-Type
         ; header according to the suffix of the filename.

         (1 (if (eq (cadr request) "POST")
               (error "HTTP/1.1 400 bad request")

               (println "HTTP/1.1 200 OK" (char 13))
               (send_common_headers)
               (print "Content-Type: ")

               (if (and (setq result (matches suffix_rx file))
                        (setq result (alist_lookup (car result) types)))
                  (print (car result))
                  (print "text/plain"))

               (println (char 13))
               (println "Content-Length: " (caddddr size) (char 13))
               (when close
                  (println "Connection: close" (char 13)))
               (println (char 13))

               (when (eq "GET" (cadr request))
                  (with_input_file file
                     (while (setq line (getchars 100000))
                        (print line))))))))

; Function to extract the information from the request header we need
; to fulfill the request.

(defun parse_request_header ()
   (setq content_length "")
   (setq cookie "")
   (setq agent "")
   (setq host "")
   (setq expect_100 0)

   (catch

      ; We use "getline_ub" here because it is necessary to read lines
      ; without the buffering performed by "getline", so that when we fork
      ; a CGI program, and it inherits the socket descriptor on stdin,
      ; there is no buffered data in the parent unavailable to the child,
      ; after the "exec".

      (unless (setq request (getline_ub 2))
         (throw (setq close 1)))

      (while (and (setq line (getline_ub 2)) (setq line (chomp line)))
         (cond ((setq m (matches host_rx line))
                (setq host (cadr m)))

               ((setq m (matches length_rx line))
                (setq content_length (cadr m)))

               ((setq m (matches agent_rx line))
                (setq agent (cadr m)))

               ((setq m (matches cookie_rx line))
                (setq cookie (cadr m)))

               ((match expect_rx line)
                (setq expect_100 1))

               ((match close_rx line)
                (setq close 1))))

      (when (eq line 0)
         (throw (setq close 1)))))

; Server child main loop.

(while (and (fixnump (setq result (accept))) (>= result 0))
   (busy busy_idx)

   (for (((setq close 0)) ((not close)) ())

      ; Bail out if we read EOF from the client prematurely.

      (when (parse_request_header)
         (continue))

      ; We only recognize HEAD, GET and POST requests.  Requests with ../
      ; components are rejected.

      (if (or (match parent_rx request)
              (not (setq request (matches get_rx request)))
              (and host (not (member host hostnames))))
         (error "HTTP/1.1 400 bad request")

         ; Close connection after response for an HTTP/1.0 request.

         (when (eq (cadddr request) "0")
            (setq close 1))

         ; Check for a request for root resource.

         (if (eq (caddr request) "/")
            (setq file root_doc)
            (setq file (caddr request)))

         (process_request)
         (flush_stdout)))

   ; Close the connection.

   (resume 0)
   (resume 1)
   (notbusy busy_idx))

(when (stringp result)
   (syslog 'ERROR (concat "accept(): " result))
   (exit 1))

(quit)
