#!/usr/bin/env openlisp -shell
;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:ISLISP -*-
;;;; Title:     httpd.lsp
;;;; Author:    C. Jullien
;;;; License:   New BSD license
;;;; SVN:       "$Id: httpd.lsp 5565 2022-08-20 07:07:01Z jullien $"

;;;
;;; Simple httpd - web server
;;;
;;; Only manage GET, HEAD and POST requests (see RFC 2616).
;;;
;;; USAGE: (httpd port root-dir)
;;;
;;; $ openlisp -shell httpd.lsp 80 .
;;;

;;;
;;; Please try to avoid allocation as much as possible!!!
;;;

(require "setf")
(require "defstruct")
(require "datetime")
(require "logger")
(require "sysinfo")
(require "sort")
(require "url")
(require "http")

;; (require "profile")

(defpackage #:httpd
  (:use    #:openlisp #:http #:logger)
  (:export
           ;; CGI variables
           #:*QUERY-LIST*
           #:*QUERY-FORM*
           #:*BODY-CONTENT*
           #:*HEADER-LIST*
           ;; public interface
           #:httpd
           #:httpd-echo-binary-file
           #:httpd-send-binary-file
           #:httpd-send-file
           #:httpd-shell)
)

(in-package #:httpd)

;;;
;;; *QUERY-LIST* is a global variable that contains QUERY from POST or
;;; GET method.
;;;

(defglobal *QUERY-LIST*   nil)

;;;
;;; *QUERY-FORM* is a global variable that contains FORM from POST
;;; method.
;;;

(defglobal *QUERY-FORM*   nil)

;;;
;;; *BODY-CONTENT* is a global variable that contains body part from
;;; POST method.
;;;

(defglobal *BODY-CONTENT* nil)

;;;
;;; *HEADER-LIST* is a global variable that contains the HEADER from
;;; POST method.
;;;

(defglobal *HEADER-LIST*  nil)

;;;
;;; You can control log requests with *httpd-logfile* and *httpd-debug-level*
;;; *httpd-logfile* can be:
;;;   t            log messages on console
;;;   <filename>   log messages on the file named <filename>
;;;   nil          no log.
;;; *httpd-debug-level* is one of logger.lsp supported levels.

;;;
;;; Internal variables.
;;;

(defmacro check-def (name value)
   `(if (gboundp ',name) ,name ,value))

(defglobal *httpd-version*     (check-def *httpd-version*     "HTTP/1.1"))
(defglobal *httpd-root*        (check-def *httpd-root*        "."))
(defglobal *httpd-port*        (check-def *httpd-port*        8080))
(defglobal *httpd-default*     (check-def *httpd-default*     "index.html"))
(defglobal *httpd-config*      (check-def *httpd-config*      "httpd.cnf"))
(defglobal *httpd-logfile*     (check-def *httpd-logfile*     t))
(defglobal *httpd-max-fd*      (check-def *httpd-max-fd*      8))
(defglobal *httpd-timeout*     (check-def *httpd-timeout*     1.0))
(defglobal *httpd-running*     (check-def *httpd-running*     nil))
(defglobal *httpd-pid-list*    (check-def *httpd-pid-list*    nil))
(defglobal *httpd-max-len*     (check-def *httpd-max-len*     #xFFFF))
(defglobal *httpd-try-fork*    (check-def *httpd-try-fork*    t))
(defglobal *httpd-nodelay*     (check-def *httpd-nodelay*     nil))
(defglobal *httpd-read-buffer* (check-def *httpd-read-buffer* nil))
(defglobal *httpd-debug-level* (check-def *httpd-debug-level* :info))
(defglobal *httpd-date*        (check-def *httpd-date*        (make-date)))
(defglobal *httpd-server*      (check-def *httpd-server*      nil))
(defglobal *httpd-force-close* (check-def *httpd-force-close* t))
(defglobal *httpd-bufsize*     (check-def *httpd-bufsize*     stdc:|OLMAXIOBUFLEN|))
(defglobal *httpd-loop*        (check-def *httpd-loop*        t))

;;;
;;; Server: string
;;;

(defun httpd-server-name ()
   ;; compute the Server information header.
   (or *httpd-server*
       (let ((info (system-info)))
            (setf *httpd-server*
                  (format () "Server: OpenLisp/~G (~A, ~A)"
                          (version)
                          (system-name)
                          (sysinfo-character-set info))))))

;;;
;;; Debug level: 0=no 1=minimal 2=full
;;;

(defun httpd-get-debug-level ()
   ;; Get the debug level (a number).
   (if (getenv "OLHTTPDEBUG")
       (let ((level (read-from-string (getenv "OLHTTPDEBUG"))))
            (log-set-level level)
            level)
       *httpd-debug-level*))

;;;
;;; Log  requests  and  other  infos  if  *httpd-logfile* is set to a
;;; valid filename. Default is NO logging.
;;;

(defun httpd-log (level fmt &rest args)
   ;; Print values using given format string.
   (when (and *httpd-logfile* (loggable-p (current-logger) level))
         ;; print a log entry in logfile.
         (apply #'logger-add-entry (current-logger) level fmt args)))

;;;
;;; Supported Mime types.
;;;

(defglobal *httpd-mime-types*
           '(("txt"   . "text/plain")
             ("html"  . "text/html")
             ("htm"   . "text/html")
             ("csv"   . "text/csv")
;            (""      . "text/directory")
             ("shtml" . "text/html")
             ("gif"   . "image/gif")
             ("jpg"   . "image/jpeg")
             ("jpeg"  . "image/jpeg")
             ("png"   . "image/png")
             ("pdf"   . "application/pdf")
             ("lsp"   . "application/lisp")
             ("json"  . "application/json")
;            ("mmi"   . "application/mmi")
             ("doc"   . "application/msword")
             ("rss"   . "application/rss+xml")
             ("rtf"   . "application/rtf")
             ("exe"   . "application/octet-stream")
             ("odsp"  . "application/odsp")
             ("xml"   . "application/xml")
             ("dtd"   . "application/dtd")
             ("tgz"   . "application/x-tar")
             ("tar"   . "application/x-tar")
             ("gz"    . "application/x-gzip")
             ("gzip"  . "application/x-gzip")
             ("zip"   . "application/x-zip")
             ("bz2"   . "application/x-bzip2")
             ("css"   . "application/x-pointplus")
             ("cgi"   . "server/cgi") ;; application/x-httpd-cgi
))

;;;
;;; Structure for a request
;;;

(defstruct (<request>
             (:copier    nil)
             (:predicate nil))
           ;; full request header
           header
           ;; body (in case of a POST method)
           body
           ;; request type (GET, POST ..)
           type
           ;; HTTP version: HTTP/1.0 or HTTP/1.1
           version
           ;; connection parameters (like Keep-Alive)
           connection)

;;;
;;; Manage a pool of opened connections.
;;;

(defglobal *httpd-client-list* ())
(defglobal *httpd-client-max*  0)

(defun httpd-add-socket (so)
   ;; insert the socket so and its associated timestamp.
   (push (cons (get-universal-time) so) *httpd-client-list*))

(defun httpd-close-old-socket (sec)
   ;; close and remove socket older than 'sec' seconds.
   (let ((len (length *httpd-client-list*)))
        (when (> len *httpd-client-max*)
              (setf *httpd-client-max* len))
        (httpd-log :debug "Checking for dead sockets (size=~d/~d)"
                   len
                   *httpd-client-max*))
   (let ((old  (- (get-universal-time) sec))
         (l    (nreverse *httpd-client-list*)))
        (while (and l (< (caar l) old))
               (httpd-log :debug "Closing ~s (~ds)." (cdar l) sec)
               (close (cdar l))
               (setf l (cdr l)))
        (setf *httpd-client-list* (nreverse l))))

;;;
;;; Error handlers
;;;

(defun httpd-error-handler (error)
   ;; Error handler function.
   (when (eq (class-of error) (class <user-interruption>))
         (httpd-log :notice "^C received, shutdown HTTPD server.")
         (let ((pidfile (httpd-pid-file *httpd-port*)))
              (when (probe-file pidfile)
                    (delete-file pidfile)))
;;       (profile-log :calls)
         (end))
   ;; WARNING:  we  should  try  to  send a "500 Server error" and to
   ;; close the connection. This may be source of ressource leaks.
   (httpd-log :err "caught: ~s" error)
   (when (log-loggable-p :debug)
         (httpd-log :debug "Stack-Trace:")
         (let ((stack -1))
              (dolist (frame (stack-trace 10))
                      (httpd-log :debug
                                 "  [~2,'0d] (~s ...)" (incf stack) frame)))))
                    

(defun httpd-server-handler (error)
   ;; toplevel error handler
   (httpd-error-handler error)
   (throw 'httpd-server-handler nil))

(defun httpd-client-handler (error)
   ;; client error handler
   (httpd-error-handler error)
   (throw 'httpd-client-handler 500))

;;;
;;; Main function
;;;

(defun httpd (port rootdir &rest kill-prev)
   ;; forever protected loop
   (when (probe-file *httpd-config*)
         (load *httpd-config*))
   (with-logger (if (eq *httpd-logfile* t)
                    (create (class <console-logger>)
                            :level (httpd-get-debug-level))
                    (create (class <file-logger>)
                            :level (httpd-get-debug-level)
                            :file  *httpd-logfile*))
      (setf *httpd-root* (or rootdir "."))
      (setf *httpd-port* port)
      (when *httpd-config*
            (httpd-log :notice "Using config: ~s." *httpd-config*))
      ;; kill previous instance using saved PID
      (let ((pidfile (httpd-pid-file *httpd-port*))
            (pid     0))
           (when (and kill-prev (probe-file pidfile))
                 (with-open-input-file (st pidfile)
                      (setf pid (read st))
                      (httpd-log :warning "Kill previous server, PID=~s." pid)
                      (kill pid 0)
                      (sleep 500)))
           ;; save current PID
           (with-open-output-file (st pidfile)
                (format st "~a" (getpid))))
      (while *httpd-loop*
             (catch 'httpd-server-handler
                    (with-handler #'httpd-server-handler
                                  (httpd-server))))))

(defun httpd-pid-file (port)
   ;; build PID file "httpd-XXXX-.pid"
   (format () "httpd-~4,'0d.pid" port))

(defun httpd-running-p ()
   ;; return t if the server is running.
   *httpd-running*)

(defun httpd-get-root ()
   ;; get the root directory of the httpd sever.
   *httpd-root*)

(defun httpd-set-root (root)
   ;; change the root directory of the httpd sever.
   (setf *httpd-root* root))

(defun httpd-get-port ()
   ;; get the port of the httpd sever.
   *httpd-port*)

(defun httpd-set-port (port)
   ;; change the port of the httpd sever.
   (setf *httpd-port* port))

(defun httpd-server ()
   ;; launch the server. ^C to kill.
   (setf *httpd-read-buffer* (create-string *httpd-bufsize* #\space))
   (unless (directoryp "/tmp")
           (create-directory "/tmp"))
   (with-server-socket (server *httpd-port* :tcp)
         (let ((fdsock  (create-vector *httpd-max-fd* nil))
               (fdwrite (create-vector *httpd-max-fd* nil))
               (fdread  (create-vector *httpd-max-fd* nil))
               (timeout *httpd-timeout*))
              (declare (ignore fdwrite)) ;; not used here
              (if (dynamic *quiet-mode*)
                  ;; when *quiet-mode* debug only if level > 1
                  (unless (log-loggable-p :debug)
                          (log-set-level :err))
                  ;; show a welcome message
                  (httpd-welcome))
              (setf *httpd-running* t)
              (select-clear fdsock)
              (select-add server fdsock)
              (while *httpd-running*
                     (when *httpd-pid-list*
                           (httpd-check-exit))
                     (when *httpd-force-close*
                            ;; remove sockets not already closed.
                           (httpd-close-old-socket 2))
                     (case (select *httpd-max-fd* fdsock fdread () () timeout)
                           ((-1)
                            (httpd-log :err "Server error on SELECT .."))
                           ((0)
                            ;; Timeout ...
                            t)
                           (t
#|
                            (when (and (log-loggable-p :debug)
                                       (probe-file "httpd.lsp"))
                                  ;; to ease test
                                  (httpd-log :notice "reload httpd.lsp ..")
                                  (load "httpd.lsp"))
|#
                            (httpd-loop-connect server fdread))))
              (setf *httpd-read-buffer* ())
              (select-remove server fdsock))))

(defun httpd-make-temp ()
   ;; return a temporary file.
   (format () "/tmp/httpd~d.tmp" (getpid)))

(defun httpd-loop-connect (server fdread)
   ;; loop on read connections.
   (for ((i 0 (1+ i)))
        ((>= i *httpd-max-fd*))
        (when (elt fdread i)
              (httpd-fork-request server))))

(defun httpd-welcome ()
   ;; Welcome message.
   (httpd-log :info "OpenLisp ~a HTTPD Server." (version))
   (httpd-log :info "Hostname: ~a" (get-host-name))
   (httpd-log :info "Address:  ~a" (get-host-address (get-host-name)))
   (httpd-log :info "Port:     ~a" *httpd-port*)
   (httpd-log :info "Root dir: ~s" *httpd-root*)
   (httpd-log :info "Charset:  ~a" (if (= (system::character-size) 1)
                                       "ANSI"
                                       "UNICODE"))
   (httpd-log :info "CWD:      '~a'" (current-directory))
   (unless (or (dynamic *quiet-mode*) (null *httpd-logfile*))
           (format (standard-output) ";; OpenLisp ~a HTTPD on '~a'~%"
                   (version)
                   (get-host-name)))
   (unless (dynamic *quiet-mode*)
           (when (stringp *httpd-logfile*)
                 (format (standard-output)
                         ";; Log file: '~a'~%" *httpd-logfile*))
           (format (standard-output) ";; Hit ^C (Ctrl-C) to stop.~%")))

(defun httpd-fork-request (server)
   ;; try to fork a new process that will run httpd-request.
   (let ((pid (if *httpd-try-fork* (fork) -1)))
        (case pid
              ((-1) ;; can't (or don't want to) fork on this system
                    (httpd-request server))
              ((0)  ;; child is now running
                    (httpd-log :debug "child, pid=~d" (getpid))
                    (httpd-request server)
                    (end 0))
              (t    ;; save client pid.
                    (push pid *httpd-pid-list*)
                    (httpd-log :debug "pid ~d, forked process id=~d"
                               (getpid) pid)
                    pid))))

(defun httpd-check-exit ()
   ;; check for exit code.
   (dolist (pid *httpd-pid-list*)
           (let ((res   (waitpid pid 'WNOHANG))
                 (errno 0))
                (cond
                      ((> res 0)
                       (httpd-log :debug
                                  "process pid=~d exited res=~d." pid res)
                       (setf *httpd-pid-list* (remove pid *httpd-pid-list*)))
                      ((= res 0)
                       ;; process pid is still running.
                       t)
                      (t
                       (setf *httpd-pid-list* (remove pid *httpd-pid-list*))
                       (setf errno (system-errno))
                       (httpd-log :debug
                                  "process pid=~d exited with code ~d"
                                  pid
                                  errno))))))

(defun httpd-request (server)
   ;; get client and process request
   (let ((client (accept server))
         (time   (get-internal-run-time)))
        (if client
            (unwind-protect
                   (progn
                          (socket-nonblocking client nil)
                          ;; set timeout.
                          (socket-receive-timeout client *httpd-timeout*)
                          (socket-send-timeout    client *httpd-timeout*)
                          ;; force NODELAY mode.
                          (when (and *httpd-nodelay*
                                     (null (socket-nodelay client t)))
                                (httpd-log :warning
                                           "NODELAY not supported!!"))
                          (catch 'httpd-exit-status
                                 (httpd-process-request
                                        client
                                        (httpd-get-request client))))
                   ;; cleanup forms:
                   (httpd-log :debug "Elapsed time: ~s."
                          (quotient (- (get-internal-run-time) time)
                                    (internal-time-units-per-second)))
                   (cond
                         (*httpd-force-close*
                          (httpd-log :debug "Close socket")
                          ;; maybe (shutdown client 1) ?
                          (close client))
                         (t
                          (httpd-log :debug "Add socket to pool")
                          (httpd-add-socket client)))
                   t)
            (httpd-log :err "Error, can't accept connection"))))

(defun httpd-file-type (file)
   ;; return file type from URI extension.
   (let ((start 0)
         (stop  nil)
         (len   (length file)))
        (for ((i 0 (+ i 1)))
             ((= i len))
             (when (or (char= (elt file i) #\.)
                       (char= (elt file i) #\/))
                   (setf start i))
             (when (char= (elt file i) #\?)
                   (setf stop i)
                   (setf i (- len 1))))
        (if stop
            (subseq file (+ start 1) stop)
            (subseq file (+ start 1)))))

(defun httpd-get-request (client)
   ;; read a command from client.
   ;; -> "GET /foo/bar.html HTTP/1.1"
   (let ((request (httpd-read-request-header client))
         (header  nil)
         (type    nil))
        (setf header (request-header request))
        (when (consp header)
              (setf type (car header)))
        (cond
              ((null type)
               (httpd-send-status client 400))
              ((not (member (car type) '(:GET :POST :HEAD)))
               (httpd-log :err "Unsupported ~a method " (car type))
               (httpd-send-status client 400))
              (t
               (setf (request-type request) type)
               request))))

(defun httpd-read-request-header (client)
   ;; read the client request and return result as a request object.
   (let ((header     nil)
         (body       nil)
         (connection nil)
         (line       nil)
         (version    nil)
         (len        0))
        ;;
        ;; read header until first blank line
        ;;
        (while (and (setf line (read-line client nil nil))
                    (> (length line) 0))
               (push line header))
        (setf header (http-decode-header (nreverse header)))
        ;;
        ;; parse "Content-Length:" and read body.
        ;;
        (setf len (assoc :content-length header))
        (cond
              ((and (consp len) (cdr len) (consp (cdr len)))
               (setf len (read-from-string (cadr len)))
               (when (or (not (integerp len)) (> len *httpd-max-len*))
                     ;; content-length is too large.
                     (httpd-send-status client 413))
               (socket-nonblocking client t)
               (setf body (create-string len #\space))
               (receive client body)
               (socket-nonblocking client nil))
              ((assoc :POST header)
               ;; content-length is required for a POST method.
               (httpd-send-status client 411)))
        ;;
        ;; parse "connection:"
        ;;
        (setf connection (cassoc :connection header))
        (setf line (nth 0 header))
        ;;
        ;; parse "HTTP/x.x" client version
        ;;
        (setf version (or (member "HTTP/1.1" line :test #'equal)
                          (member "HTTP/1.0" line :test #'equal)))
        (if (consp version)
            (setf version (car version))
            (setf version "HTTP/1.0"))
        ;;
        ;; Check that host has been sent (as required by HTTP 1.1)
        ;;
        (when (and (string-equal *httpd-version* "HTTP/1.1")
                   (string-equal version         "HTTP/1.1")
                   (null (assoc :host header)))
              ;; "Host:" was missing.
              (httpd-log :warning "Host: was missing from HTTP/1.1 request")
;;              (httpd-send-status client 400)
              t)
        ;;
        ;; make a new request
        ;;
        (make-request :header     header
                      :body       body
                      :version    version
                      :connection connection)))

(defun httpd-send-header (client mime-type file)
   ;; send HTTP response header.
   (with-output-to-string (so)
         (http-format-nl so "~a 200 OK" *httpd-version*)
         (http-format-nl so "~a" (httpd-server-name))
         (http-format-nl so "Date: ~A" (get-internal-date *httpd-date* :gmt))
         ;;  (http-format-nl so "ETag: \"a9833-2d6-fff49fc0\"")
         ;;  (http-format-nl so "Accept-Ranges: bytes")
         ;;  (if (string-equal *httpd-version* "HTTP/1.0")
         ;;      (http-format-nl so "Pragma: no-cache")
         ;;      (http-format-nl so "Cache-Control: no-cache"))
         ;; (http-format-nl so "Set-Cookie2: Openlisp=\"~A\"; Version=\"1\""
         ;;                    (version))
         (http-format-nl so "Connection: close")
         (http-format-nl so "Content-Type: ~A" mime-type)
         (cond
               ((null file)
                (http-format-nl so "Last-Modified: ~A~%"
                                (get-internal-date *httpd-date* :gmt)))
               ((probe-file file)
                (http-format-nl so "Last-Modified: ~A"
                                (file-date file *httpd-date* :gmt))
                (http-format-nl so "Content-Length: ~D"
                                (file-length file 8)))
               ((stringp file)
                (http-format-nl so "Content-Length: ~D" (length file)))
               (t
                (http-format-nl so "Last-Modified: ~A~%"
                                (get-internal-date *httpd-date* :gmt))))
         (http-format-nl so)
         (send client (get-output-stream-string so))))

(defun httpd-reply-header (client status msg)
   ;; send reply header using the current HTTP version adding CR/LF.
   ;; -> "HTTP/1.1 404 Not Found"
   (with-output-to-string (so)
         (http-format-nl so "~a ~d ~a~%" *httpd-version* status msg)
         (http-format-nl so "~a" (httpd-server-name))
         (http-format-nl so "Date: ~A~%" (get-internal-date *httpd-date* :gmt))
         (http-format-nl so "Connection: close")
         (http-format-nl so)
         (send client (get-output-stream-string so))))

(defun httpd-send-status (client status)
   ;; Send an error?
   (httpd-reply-header client status (http-status-message status))
   (httpd-log :debug "Status = ~a." status)
   (unless (< status 400)
           ;; 10x, 20x and 30x codes are not errors.
           (throw 'httpd-exit-status nil)))

(defun httpd-check-valid-mime-type (client file)
   ;; check if the file as a known mime type.
   (if (null file)
       (httpd-send-status client 404)
       (or
           (cassoc (httpd-file-type file) *httpd-mime-types* :test #'equal)
           ;; try with text/plain
           "text/plain")))

(defun httpd-query-to-alist (query)
   ;; transfom a query to A-list.
   ;; "foo=3&bar&gee=5" -> '(("foo" . "3") ("bar") ("gee" . "5"))
   ;; DEBUG:   (httpd-log :info "httpd-query-to-alist ~a" query)
   (mapcar (lambda (x)
              (setf x (string-split "=" x))
              (cons (first x) (second x)))
           (string-split "&" (url:url-decoder query))))

(defun httpd-process-request (client request)
   ;; process client request.
   (let* ((type     (request-type request))
          (header   (request-header request))
          (method   nil)
          (file     nil)
          (content  nil)
          (mdate    nil)
          (udate    nil)
          (args     nil)
          (mimetype nil))
         (setf method (nth 0 type))
         (setf file   (nth 1 type))
         ;;
         ;; Reset query and header arg list.
         ;;
         (setf *BODY-CONTENT* nil)
         (setf *HEADER-LIST*  nil)
         (setf *QUERY-FORM*   nil)
         (setf *QUERY-LIST*   nil)
         (httpd-log :debug "QUERY:  ~a" type)
         (httpd-log :debug "HEADER: ~a" request)
         ;;
         ;; Split query into URI and arguments.
         ;;
         (setf args (string-split "?" (string-append *httpd-root* file)))
         (setf file (pop args))
         (when (directoryp file)
               ;; append default-file (index.html)
               (let ((index file))
                    (unless (member (elt file (1- (length file)))
                                    '(#\/ #\/))
                            (setf index (string-append file "/")))
                    (setf index (string-append index *httpd-default*))
                    (when (probe-file index)
                          (setf file index))))
         (httpd-log :debug "URI: ~a" file)
         ;;
         ;; Convert arguments into an A-List for better access.
         ;;
         (when args
               (setf *QUERY-LIST* (httpd-query-to-alist (car args)))
               (httpd-log :debug "Args: ~s" *QUERY-LIST*))
         ;;
         ;; Get MIME type from URI extension used.
         ;;
         (setf mimetype (httpd-check-valid-mime-type client file))
         ;;
         ;; Process Request.
         ;;
         (if *QUERY-LIST*
             (httpd-log :debug "~a ~s ~s" method file *QUERY-LIST*)
             (httpd-log :debug "~a ~s" method file))
         (case (and mimetype method)
               ((:GET)
                ;; GET Method
                ;; The   GET  method  retrieves  the  information  or
                ;; entity  that  is  identified  by  the  URI  of the
                ;; Request.  If  that URI refers to a script or other
                ;; data-producing  process,  it is the data produced,
                ;; not  the  text of the script,  that is returned in
                ;; the response.
                ;; A  GET  method  can be made conditional or partial
                ;; by  including  a conditional or Range header field
                ;; in  the  request.  A conditional GET requests that
                ;; the   entity   be  sent  only  if  all  conditions
                ;; specified  in  the  header are met,  and a partial
                ;; GET   requests   only   part  of  the  entity,  as
                ;; specified  in  the  Range  header.  Both  of these
                ;; forms  of  GET  can help avoid unnecessary network
                ;; traffic. See page 53 of RFC 2616.
                (httpd-set-connection-options client request)
                (httpd-log :info "Process 'GET ~a' (~a)" file mimetype)
                (cond
                      ((string-index ".." file)
                       ;; ".." is forbidden in the request.
                       (httpd-send-status client 403))
                      ((or (equal mimetype "server/cgi")
                           (eq (string-index "application/" mimetype) 0))
                       ;; always load/execute applications or server scripts.
                       (httpd-send-file client file mimetype))
                      ((eq (string-index "application/" mimetype) 0)
                       ;; always load/execute application
                       (httpd-send-file client file mimetype))
                      ((directoryp file)
                       (let ((html (httpd-directory file)))
                            (httpd-send-header client "text/html" html)
                            (send client html)))
                      ((probe-file file)
                       ;; File is found, just send
                       (setf mdate (cassoc :If-Modified-Since   header))
                       (setf udate (cassoc :If-Unmodified-Since header))
                       (cond
                             ((and mdate
                                   (date<= (file-date file nil :gmt) mdate))
                              ;; send "304 Not Modified"
#|
                              (httpd-log :debug "~s m ~s" file mdate)
                              (httpd-log :debug "~s f ~s" file
                                     (file-date file nil :gmt))
|#
                              (httpd-send-status client 304))
                             ((and udate
                                   (date> (file-date file nil :gmt) udate))
                              ;; send "304 Not Modified"
                              (httpd-send-status client 304))
                             (t
                              ;; modified, send the file.
                              (httpd-send-file client file mimetype))))
                      ((or (regmatch "eval-hook.html$" file)
                           (regmatch "eval-hook.asp$" file))
                       ;; special hook
                       (socket-nonblocking client nil)
                       (httpd-send-header client "text/plain" nil)
                       (format client "~%~%GC: ~S~%~%" (gc t))
                       (pretty 'httpd-process-request client)
                       t)
                      (t
                       (httpd-send-status client 404))))
               ((:POST)
                ;; POST Method
                ;; The  POST  method  is used to post a new entity as
                ;; an  addition  to  a  URI.  The  URI  identifies an
                ;; entity  that  consumes  the  posted  data  in some
                ;; fashion. See page 54 of RFC 2616.
                (setf *HEADER-LIST*  (request-header request))
                (setf *BODY-CONTENT* (request-body   request))
                (setf content        (cassoc :Content-Type *HEADER-LIST*))
                (httpd-log :debug "Process POST ~a type: ~a" file mimetype)
                (when (consp content)
                      (when (equal "application/x-www-form-urlencoded"
                                   (car content))
                            (ignore-errors
                               (setq *QUERY-FORM*
                                     (httpd-query-to-alist *BODY-CONTENT*))))
                      (httpd-log :debug "Query form: ~s" *QUERY-FORM*))
                (when (log-loggable-p :debug)
                      (httpd-log :debug "Header:")
                      (dolist (x *HEADER-LIST*)
                              (httpd-log :debug "~a" x))
                      (httpd-log :debug "Body:~%~a" *BODY-CONTENT*))
#| Should we send 100 (Continue) ?
                (httpd-send-status client 100)
|#
                (cond
                      ((probe-file file)
                       ;; File is found, just send
                       (httpd-send-file client file mimetype))
                      (t
                       (httpd-send-status client 404))))
               ((:HEAD)
                ;; HEAD  Method.
                ;; The  HEAD  method  is identical to GET except that
                ;; the  server  only  returns  message-headers in the
                ;; response,  without a message-body. The headers are
                ;; the  same  as  would  be returned in response to a
                ;; GET. See page 54 of RFC 2616. 
                (httpd-log :info "Process HEAD ~a type: ~a" file mimetype)
                (setf file (string-append *httpd-root* file))
                (if (probe-file file)
                    (httpd-send-header client mimetype file)
                    (httpd-send-status client 404)))
               ((:CONNECT :DELETE :OPTIONS :PUT :TRACE)
                ;; Not implemented
                (httpd-send-status client 501))
               (t
                (httpd-send-status client 405)))
         t))

(defun httpd-set-connection-options (client request)
   ;; set connection option requested by client (like keep-alive).
   ;; Other options (which ones?) are not supported.
   (case-using #'string-equal (request-connection request)
        (("close")
         (httpd-log :debug "'Connection: close' option not handled.")
         nil)
        (("Keep-Alive")
         (socket-keepalive client t))
        (t
         ;; unsupported option, ignore
         nil)))

;;;
;;; Data transfert from server to client (file, directory ...).
;;;

(defun httpd-send-binary-file (socket file type)
   ;; This version uses the "C" low-level interface and should be faster.
   ;; It requires standard "external.c" module.
   (let ((fd   (stdc:fopen file "rb"))
         (buf  (or *httpd-read-buffer* (create-string *httpd-bufsize* #\Space)))
         (loop t)
         (sum  0)
         (len  0))
        (cond
              (fd
                (httpd-send-header socket type file)
                (unwind-protect
                  (while (and loop
                              (> (setf len
                                       (stdc:fread buf 1 *httpd-bufsize* fd))
                                 0))
                         (setf sum (+ sum len))
                         (unless (send socket buf len)
                                 (httpd-log :err
                                            "SEND error: err=~a, len=~a"
                                            (system-errno)
                                            len)
                                 (setf loop nil)))
                   (stdc:fclose fd)))
              (t
                ;; file not found or premission denied
                (httpd-send-status socket 404)))))

(defun httpd-echo-binary-file (file)
   ;; Helper for CGI scripts.
   ;; This version uses the "C" low-level interface and should be faster.
   ;; It requires standard "external.c" module.
   (let ((fd  (stdc:fopen file "rb"))
         (buf (or *httpd-read-buffer* (create-string *httpd-bufsize* #\Space)))
         (out (convert (standard-output) <external>))
         (len 0))
        (cond
              (fd
                (unwind-protect
                  (while (> (setf len
                                  (stdc:fread buf 1 *httpd-bufsize* fd))
                            0)
                          (stdc:fwrite buf 1 len out))
                   (stdc:fclose fd)))
              (t
                ;; file not found or premission denied
                (httpd-log :err "Can't echo: ~s." file)))))

(defun httpd-send-file (client file type)
   ;; send the file requested by the client.
   (let ((tmp nil))
        (case-using #'string-equal type
              (("image/gif" "image/jpeg" "image/png")
               ;; Image
               (httpd-send-binary-file client file type))
              (("application/lisp" "server/cgi")
               ;; Lisp code
               (setf tmp (httpd-make-temp))
               (with-open-output-file (strm tmp)
                     (with-standard-output strm
                           (ignore-errors (load file))))
               (httpd-send-binary-file client tmp "text/html"))
              (("application/odsp")
               ;; OpenLisp Dynamic Server Page
               (setf tmp (httpd-make-temp))
               (with-open-output-file (strm tmp)
                     (with-standard-output strm
                           (ignore-errors (odsp file))))
               (httpd-send-binary-file client tmp "text/html"))
              (t
               ;; Other files are sent directly?
               (httpd-send-binary-file client file type)))
        (when (and tmp
                   (probe-file tmp)
                   (not (log-loggable-p :debug)))
              (delete-file tmp))))

(defun httpd-directory (dir)
   ;; prepare an HTML string that represents directory structure
   (let ((dir-list ())
         (path     ()))
        (dolist (name (expand-pathname dir))
                (unless (directoryp (string-append dir "/" name))
                        (push name dir-list)))
        (setf dir-list (sortl dir-list))
        (with-output-to-string (so)
              (format so "<html>~%")
              (format so " <head>~%")
              (format so "  <title>Index of ~a</title>~%" dir)
              (format so " </head>~%")
              (format so "<body>~%")
              (format so " <h1>Index of ~a</h1>~%" dir)
              (format so " <pre>~%")
              (format so "Size      Name~%")
              (format so "<hr />~%")
              (dolist (name dir-list)
                      (setf path (string-append dir "/" name))
                      (format so "~9d <a href=\"~a\">~a</a>~%"
                              (file-length path 8)
                              path
                              name))
              (format so "</pre>~%")
              (format so "<hr />~%")
              (format so "<i>OpenLisp v~g [~a]"
                      (version)
                      (get-internal-date nil :gmt))
              (format so "</body>~%")
              (format so "</html>~%")
              (get-output-stream-string so))))

;;;
;;; Toplevel shell function
;;;

(defun httpd-shell ()
   ;; Test if launched as a script
   (when (and (not *httpd-running*) (regmatch "http" $0))
         ;; if launched as a script.
         (let ((port     *httpd-port*)
               (root     *httpd-root*)
               (toplevel nil)
               (cmd      $0))
              (while (and $1 (eql #\- (elt $1 0)))
                     (case-using #'string-equal $1
                           (("-quiet")
                            ;; quiet mode
                            (shift))
                           (("-toplevel")
                            ;; toplevel
                            (setf toplevel t)
                            (shift))
                           (("-port")
                            (setf port $2)
                            (shift)
                            (shift))
                           (("-root")
                            (setf root $2)
                            (shift)
                            (shift))
                           (t (error "HTTPD: unsupported option ~s" $1))))
              (when (stringp port)
                    (setf port (ignore-errors (parse-number port)))
                    (unless port
                            (format (error-output) "~a: Invalid port.~%" cmd)))
              (unless toplevel
                      (httpd port root)))))

(provide "httpd")

(httpd-shell)