;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
;;;;
;;;; This is a minimal standalone Common Lisp HTTP Server
;;;;
;;;; Copyright (C) 2005,2006,2007,2008 Sven Van Caekenberghe, Beta Nine BVBA.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser General Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

(in-package :s-http-server)

;; globals

(defvar *http-server-identification* 
  (format nil "S-HTTP-SERVER ~a ~a" (lisp-implementation-type) (lisp-implementation-version))
  "Identification string sent as value of the 'Server' HTTP Response Header")

(defvar *http-server-port* 1701
  "Default port used when creating a new S-HTTP-SERVER")

(defclass s-http-server ()
  ((port :accessor get-port :initarg :port :initform *http-server-port*)
   (name :accessor get-name :initarg :name :initform "s-http-server")
   (debug-mode :accessor get-debug-mode :initarg :debug-mode :initform t)
   (server-process :accessor get-server-process :initform nil)
   (http-connections :accessor get-http-connections :initform nil)
   (log-stream :accessor get-log-stream :initarg :log-stream :initform nil)
   (access-log-stream :accessor get-access-log-stream :initarg :access-log-stream :initform nil)
   (log-lock :accessor get-log-lock :initform (s-sysdeps:make-process-lock "s-http-server-log-lock"))
   (boot-time :accessor get-boot-time :initform nil)
   (last-periodic-check :accessor get-last-periodic-check :initform (get-universal-time))
   (contexts :accessor get-contexts :initarg :contexts 
             :initform '((s-http-server-handler "/s-http-server" :builtin)
                         (favicon-handler "/favicon.ico" :builtin))))
  (:documentation "The object representing a minimal standalone HTTP Server"))

(setf (documentation 'get-port 'function)
      "Get the TCP port used by this S-HTTP-SERVER"
      (documentation 'get-name 'function)
      "Get the current name of this S-HTTP-SERVER"
      (documentation 'get-debug-mode 'function)
      "Get the current mode of debugging of this S-HTTP-SERVER, t is on, nil is off"
      (documentation 'get-server-process 'function)
      "Get the current server process used by this S-HTTP-SERVER, nil if not running"
      (documentation 'get-client-processes 'function)
      "Get the list of active (including kept-alive) client processes used by this S-HTTP-SERVER"
      (documentation 'get-boot-time 'function)
      "Get the universal time when this S-HTTP-SERVER was last started, nil if not running"
      (documentation 'get-log-stream 'function)
      "Get the current stream used by this S-HTTP-SERVER for general logging, nil means no logging"
      (documentation 'get-access-log-stream 'function)
      "Get the current stream used by this S-HTTP-SERVER for access logging, nil means no logging"
      (documentation 'get-contexts 'function)
      "Get the current list of context bindings used by this S-HTTP-SERVER")

#-allegro
(setf (documentation '(setf get-port) 'function)
      "Set the port of this S-HTTP-SERVER (before starting the server)"
      (documentation '(setf get-name) 'function)
      "Set the name of this S-HTTP-SERVER"
      (documentation '(setf get-debug-mode) 'function)
      "Set the current debugging mode of this S-HTTP-SERVER, t is on, nil is off"
      (documentation '(setf get-log-stream) 'function)
      "Set the stream this S-HTTP-SERVER uses for general logging, nil means no logging"
      (documentation '(setf get-access-log-stream) 'function)
      "Set the stream this S-HTTP-SERVER uses for access logging, nil means no logging")

(defun make-s-http-server (&key 
                           (port *http-server-port*)
                           (name "s-http-server")
                           (log-stream *standard-output*)
                           (access-log-stream *standard-output*))
  "Create a new object representing an S-HTTP-SERVER"
  (make-instance 's-http-server
                 :port port
                 :name name
                 :log-stream log-stream
                 :access-log-stream access-log-stream))

(defmethod print-object ((s-http-server s-http-server) stream)
  (print-unreadable-object (s-http-server stream :type t :identity t)
    (with-slots (name port server-process)
        s-http-server
      (format stream "~s port ~d ~a" name port (if server-process "running" "not running")))))

(defclass http-connection ()
  ((id :accessor get-id :initarg :id :initform -1)
   (stream :accessor get-stream :initarg :stream :initform nil)
   (process :accessor get-process :initarg :process :initform nil)
   (buffer :accessor get-buffer :initform (make-string 4096))
   (timestamp :accessor get-timestamp :initform (get-universal-time)))
  (:documentation "The object representing a kept-alive HTTP connection and handling process"))

(defmethod get-age ((http-connection http-connection))
  (- (get-universal-time) (get-timestamp http-connection)))

(defmethod print-object ((http-connection http-connection) output-stream)
  (print-unreadable-object (http-connection output-stream :type t :identity t)
    (with-slots (id stream process timestamp)
        http-connection
      (format output-stream "~d ~a ~a ~a" 
              id 
              (if process "running" "not running") 
              (if stream "connected" "not connected")
              (s-utils:format-iso-gmt-time timestamp)))))

(defclass http-request ()
  ((method :accessor get-method :initarg :method :initform :GET)
   (uri :accessor get-uri :initarg :uri :initform (puri:parse-uri "/"))
   (http-version :accessor get-http-version :initarg :http-version :initform "HTTP/1.1")
   (headers :accessor get-headers :initarg :headers :initform '())
   (keep-alive :accessor get-keep-alive :initarg :keep-alive :initform (s-sysdeps:multiprocessing-capable-p)))
  (:documentation "The object representing an HTTP request as being handled by the S-HTTP-SERVER"))

(setf (documentation 'get-method 'function)
      "Get the method (keyword :get :put :post :delete ..) of this HTTP request"
      (documentation 'get-uri 'function)
      "Get the URI object of this HTTP request"
      (documentation 'get-http-version 'function)
      "Get the HTTP version string of this HTTP request"
      (documentation 'get-headers 'function)
      "Get the dotted alist (:keyword . 'value') of request headers of this HTTP request"
      (documentation 'get-keep-alive 'function)
      "Is this a keep-alive request (either 1.0 or 1.1)")

(defgeneric get-path (http-request)
  (:method ((http-request http-request))
   (puri:uri-path (get-uri http-request)))
  (:documentation "Get the path of this HTTP request"))

(defgeneric get-full-path (http-request)
  (:method ((http-request http-request))
   (puri:render-uri (get-uri http-request) nil))
  (:documentation "Get the full path of this HTTP request (including the query)"))

(defmethod print-object ((http-request http-request) stream)
  (print-unreadable-object (http-request stream :type t :identity t)
    (format stream "~a ~s" (get-method http-request) (get-path http-request))))

;; generics

(defgeneric start-server (server)
  (:documentation "Start the server"))

(defgeneric stop-server (server)
  (:documentation "Stop the server"))

(defgeneric logm (server format-string &rest args)
  (:documentation "Log a formatted message"))

(defgeneric handle-http-server-connection (server http-connection)
  (:documentation "Handle a new connection request in a new process"))

(defgeneric find-handler (server http-request)
  (:documentation "Given http-request select a handler from server"))

(defgeneric register-context-handler (server context-prefix handler-function &key arguments at-end-p do-not-replace-p)
  ;; optional handler arguments can be specified
  ;; normally, an existing context binding with the same prefix is overwritten
  ;; normally, new handlers are pushed at the front of the context bindings list
  ;; if at-end-p is t, a new binding will be added at the end of the context bindings list
  ;; if do-not-replace-p is t, an existing binding will not be overwritten and a new one will be created
  (:documentation "Configure server so that every request starting with context-prefix is sent to handler-function"))

(defgeneric unregister-context-handler (server context-prefix &key only-first-p only-last-p)
  ;; normally, all context bindings matching exactly the specified prefix are deleted
  ;; if only-first-p is t, only the first context binding with prefix is deleted
  ;; if only-last-p is t , only the last context binding with prefix is deleted
  ;; if both only-fast-p and only-last-p are t, an error is signalled
  (:documentation "Remove any configuration of server for context-prefix"))

;; setup

(defmethod start-server ((s-http-server s-http-server))
  (stop-server s-http-server)
  (let ((connection-id 0))
    (flet ((connection-handler (client-socket-stream)
             (s-sysdeps:run-process (format nil "connection-handler-~d" connection-id)
                                    #'handle-http-server-connection 
                                    s-http-server
                                    (make-instance 'http-connection 
                                                   :id (incf connection-id)
                                                   :stream client-socket-stream))
             (do-periodic-check s-http-server)))
      (setf (get-boot-time s-http-server) (get-universal-time))
      (when (not (s-sysdeps:multiprocessing-capable-p))
        (logm s-http-server "Starting a new single threaded server on port ~d and blocking" (get-port s-http-server)))
      (let ((process (s-sysdeps:start-standard-server :port (get-port s-http-server)
                                                      :name (get-name s-http-server)
                                                      :connection-handler #'connection-handler)))
        (setf (get-server-process s-http-server) process)
        (logm s-http-server "Started a new server on port ~d" (get-port s-http-server)))))
  s-http-server)

(defmethod stop-server ((s-http-server s-http-server))
  (let ((process (get-server-process s-http-server)))
    (when process
      (loop :for http-connection :in (get-http-connections s-http-server) :do 
            (with-slots (process stream)
                http-connection
              (when stream
                (ignore-errors 
                  (close stream :abort t))
                (setf stream nil))
              (when process 
                (s-sysdeps:kill-process process)
                (setf process nil))))
      (setf (get-http-connections s-http-server) nil)
      (s-sysdeps:kill-process process)
      (setf (get-server-process s-http-server) nil
            (get-boot-time s-http-server) nil)
      (logm s-http-server "Stopped server")))
  s-http-server)

(defmethod register-context-handler ((s-http-server s-http-server) context-prefix handler-function 
                                     &key arguments at-end-p do-not-replace-p)
  (let* ((new-handler-binding `(,handler-function ,context-prefix ,@arguments))
         (context-bindings (get-contexts s-http-server))
         (existing-binding (find context-prefix context-bindings :key #'second :test #'string=)))
    (if (or do-not-replace-p (null existing-binding))
        (if at-end-p
            (setf (get-contexts s-http-server) (append context-bindings (list new-handler-binding)))
          (push new-handler-binding (get-contexts s-http-server)))
      (loop :for binding :in context-bindings :do
            (destructuring-bind (function prefix &rest args)
                binding
              (declare (ignore function args))
              (when (string= prefix context-prefix)
                (setf (car binding) handler-function
                      (cddr binding) arguments)
                ;; we assume there is only one binding, more doesn't really make sense
                (return binding)))))))

(defmethod unregister-context-handler ((s-http-server s-http-server) context-prefix 
                                       &key only-first-p only-last-p)
  (let ((context-bindings (get-contexts s-http-server)))
    (cond ((and only-first-p only-last-p) (error "You cannot specify both only-first-p and only-last-p"))
          (only-first-p 
           (setf (get-contexts s-http-server) (delete context-prefix context-bindings
                                                      :key #'second :test #'string= :count 1)))
          (only-last-p 
           (setf (get-contexts s-http-server) (delete context-prefix context-prefix 
                                                      :key #'second :test #'string= :count 1 :from-end t)))
          (t 
           (setf (get-contexts s-http-server) (delete context-prefix context-bindings
                                                      :key #'second :test #'string= :count 1 :from-end t))))))

(defmethod logm ((s-http-server s-http-server) format-string &rest args)
  (let ((out (get-log-stream s-http-server)))
    (when out
      (s-sysdeps:with-process-lock ((get-log-lock s-http-server))
        (let ((server (string-upcase (get-name s-http-server)))
              (timestamp (s-utils:format-iso-gmt-time (get-universal-time)))
              (message (apply #'format nil format-string args)))
        (format out ";; ~a ~a: ~a~%" server timestamp message))))))

(defparameter +common-log-timestamp-format+
  '(#\[ :date #\/ :month-name #\/ :year #\: :hour #\: :minute #\: :second " +0000]"))

(defparameter +access-log-format+ :common-log-format
  "Either :common-log-format or :extended-common-log-format")

(defmethod log-access ((s-http-server s-http-server) http-connection http-request response bytes)
  (let ((out (get-access-log-stream s-http-server)))
    (when out
      (let ((client-ip (or (s-sysdeps:get-socket-stream-property (get-stream http-connection) :remote-host)
                           "-"))
            (timestamp (s-utils:format-universal-time (get-universal-time)
                                                      :format +common-log-timestamp-format+
                                                      :decode-in-timezone 0))
            (method (get-method http-request))
            (resource (get-full-path http-request))
            (protocol (get-http-version http-request)))
        (ecase +access-log-format+
          (:common-log-format 
           (s-sysdeps:with-process-lock ((get-log-lock s-http-server))
             (format out "~a - - ~a \"~a ~a ~a\" ~d ~d~%"
                     client-ip timestamp method resource protocol response bytes)))
          (:extended-common-log-format
           (let ((referer (or (request-header-value http-request "Referer") "-"))
                 (agent (or (request-header-value http-request "User-Agent") "-")))
             (s-sysdeps:with-process-lock ((get-log-lock s-http-server))
               (format out "~a - - ~a \"~a ~a ~a\" ~d ~d ~s ~s~%"
                       client-ip timestamp method resource protocol response bytes referer agent)))))))))

(defparameter +period-check-interval+ 60
  "Do some periodic checks every minute")

(defmethod do-periodic-check ((s-http-server s-http-server))
  (let ((now (get-universal-time)))
    (when (< +period-check-interval+ (- now (get-last-periodic-check s-http-server)))
      (logm s-http-server "Running periodic tasks")
      (cleanup-old-connections s-http-server)
      (flush-log-streams s-http-server)
      (setf (get-last-periodic-check s-http-server) now))))

(defparameter +allowed-connection-keepalive-age+ (* 60 60) 
  "Allow kept alive connections to be 1 hour inactive before they are cleaned up")

(defmethod cleanup-old-connections ((s-http-server s-http-server))
  (let ((now (get-universal-time))
        http-connections-to-remove)
    (loop :for http-connection :in (get-http-connections s-http-server) :do 
          (with-slots (process stream timestamp)
              http-connection
            (when (< +allowed-connection-keepalive-age+ (- now timestamp))
              (push http-connection http-connections-to-remove)
              (logm s-http-server "Cleaning up ~s" http-connection)
              (when stream
                (ignore-errors 
                  (close stream :abort t))
                (setf stream nil))
              (when process 
                (s-sysdeps:kill-process process)
                (setf process nil)))))
    (setf (get-http-connections s-http-server) 
          (set-difference (get-http-connections s-http-server) http-connections-to-remove))))

(defmethod flush-log-streams ((s-http-server s-http-server))
  (with-slots (log-stream access-log-stream) 
      s-http-server
    (when log-stream (force-output log-stream))
    (when access-log-stream (force-output access-log-stream))))

;; low level input/output - we are using a reusable buffer to read lines

(defun read-crlf-line (buffer stream &optional (eof-error-p t) eof-value)
  "Read a CRLF termintated line from a character input stream into buffer. Return length excluding CRLF."
  (let ((offset 0)
        (previous-char #\null))
    (loop :for char = (read-char stream eof-error-p eof-value)
          :do (cond ((equal char eof-value) 
                     (return eof-value))
                    ((and (char= char #\linefeed)
                          (char= previous-char #\return))
                     (return (1- offset)))
                    ;; for the sake of robustness (and to support clisp's eol conversions)
                    ;; we allow for a lone LF to terminate a line as well
                    ((char= char #\linefeed)
                     (return offset))
                    ((>= offset (length buffer))
                     (error "Line length exceeds buffer size (~d)" (length buffer)))
                    (t 
                     (setf (char buffer offset) char)
                     (setf previous-char char)
                     (incf offset))))))

(defun write-http-response-line (string &optional (stream *standard-output*))
  "Write string to stream, ending with the HTTP end of line convention (CR+LF)"
  (write-string string stream)
  (write-char #\return stream)
  (write-char #\linefeed stream))

(defun format-http-response-line (stream format-string &rest args)
  (write-http-response-line (apply #'format nil format-string args) stream))

;; parsing requests

(define-condition missing-http-request-line (error) ())

(defun parse-http-request-line (stream buffer)
  (let* ((line-length (read-crlf-line buffer stream nil))
         (tokens (when line-length (s-utils:tokens buffer :separators '(#\space) :end line-length))))
    (if tokens
        (values (intern (first tokens) :keyword)
                (puri:parse-uri (second tokens))
                (third tokens))
      (error 'missing-http-request-line))))

(defparameter +common-request-headers+
  (mapcar #'(lambda (header) (cons header (intern (string-upcase header) :keyword)))
          '("Host" "User-Agent" "Accept" "Accept-Language" "Accept-Encoding" "Accept-Charset"
            "Content-Length" "Content-Type" "Authorization" "Cookie" 
            "Connection" "Keep-Alive" "Cache-Control" "Pragma" "If-Modified-Since")))

(defun header-field-name->keyword (string &optional (start 0) end)
  ;; optimize the case of common request headers and avoid interning/upcasing
  (let ((common-header (find-if #'(lambda (x) 
                                    (string-equal (car x) string :start2 start :end2 end))
                                +common-request-headers+)))
    (if common-header
        (cdr common-header)
      (intern (nstring-upcase (subseq string start end)) :keyword))))

(defun header-field-value->string (string &optional (start 0) end)
  ;; skip leading whitespace
  (loop :while (and (< start end) 
                    (member (char string start) '(#\space #\tab) :test #'char=))
        :do (incf start))
  (subseq string start end))

(defun parse-http-request-headers (stream buffer)
  (loop :for line-length = (read-crlf-line buffer stream nil)
        :until (or (null line-length)
                   (zerop line-length))
        :collect (let ((colon (position #\: buffer :end line-length :test #'char=)))
                   (cons (header-field-name->keyword buffer 0 colon)
                         (header-field-value->string buffer (1+ colon) line-length)))))

(defun parse-http-request (stream buffer)
  (multiple-value-bind (http-method uri http-version)
      (parse-http-request-line stream buffer)
    (let* ((request-headers (parse-http-request-headers stream buffer))
           (http-request (make-instance 'http-request 
                                        :method http-method
                                        :uri uri
                                        :http-version http-version
                                        :headers request-headers)))
      (when (and (string-equal http-version "HTTP/1.0")
                 (string-not-equal (cdr (assoc "Connection" request-headers :test #'string-equal)) 
                                   "Keep-Alive"))
        (setf (get-keep-alive http-request) nil))
      http-request)))

;; writing/generating responses

(defun write-http-response-status-line (stream &optional (status-code 200) (string "OK") (http-version "HTTP/1.1"))
  "Write an HTTP Response Status line to stream, using status-code string and http-version"
  (format-http-response-line stream "~a ~d ~a" http-version status-code string))

(defun write-http-response-headers (headers stream)
  "Write the headers alist as HTTP Response Headers to stream"
  (loop :for (header-key . header-value) :in headers
        :do (format-http-response-line stream "~a: ~a" header-key header-value)))

(defun response-date (&optional (universal-time (get-universal-time)))
  "Generate a GMT HTTP Response Date"
  (s-utils:format-universal-time universal-time
                                 :format '(:day-name ", " :date2 #\Space :month-name #\Space :year #\Space 
                                           :hour #\: :minute #\: :second " GMT")
                                 :decode-in-timezone 0))

(defun standard-http-response-headers (http-request &key (content-type "text/plain") content-length)
  "Generate the standard headers alist given context-type and context-length, managing old-style Keep-Alive"
  `(("Server" . ,*http-server-identification*)
    ("Date" . ,(response-date))
    ,@(when content-type
        `(("Content-Type" . ,content-type)))
    ,@(when content-length
        `(("Content-Length" . ,content-length)))
    ,@(when (and http-request
                 (get-keep-alive http-request) 
                 (string-equal (get-http-version http-request) "HTTP/1.0"))
        `(("Connection" . "Keep-Alive")))
    ,@(when (and http-request
                 (not (get-keep-alive http-request)) 
                 (string-equal (get-http-version http-request) "HTTP/1.1"))
        `(("Connection" . "Close")))))

(defun escape (string)
  (with-output-to-string (stream)
    (loop :for char :across string
          :do (case char
                (#\& (write-string "&amp;" stream))
                (#\< (write-string "&lt;" stream))
                (#\> (write-string "&gt;" stream))
                (#\" (write-string "&quot;" stream))
                ((#\newline #\return #\tab) (write-char char stream))
                (t (if (and (<= 32 (char-code char))
                            (<= (char-code char) 126))
                       (write-char char stream)
                     (progn
                       (write-string "&#x" stream)
                       (write (char-code char) :stream stream :base 16)
                       (write-char #\; stream))))))))

(defvar *doctype-html-401-transitional*
  "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">")

(defvar *doctype-html-401-strict*
  "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">")

(defun standard-http-html-message-response (http-request stream title message &optional (status 200) (string "OK"))
  "Generate and write a standard HTML message as HTTP Response using title, message, status and string"
  (let ((content (with-output-to-string (out)
                   (format out 
                           "~a<html lang=\"en\"><head><title>~a</title></head><body><h1>~a</h1>~a</body></html>"
                           *doctype-html-401-strict* title title message))))
    (when stream
      (write-http-response-status-line stream status string (if http-request (get-http-version http-request) "HTTP/1.1"))
      (write-http-response-headers (standard-http-response-headers http-request
                                                                   :content-type "text/html"
                                                                   :content-length (length content)) 
                                   stream)
      (write-http-response-line "" stream)
      (write-string content stream)
      (length content))))

(defun standard-http-html-error-response (http-request stream code reason extra)
  "Generate and write a standard HTML error as HTTP Response using code, reason and extra"
  (standard-http-html-message-response http-request 
                                       stream
                                       reason
                                       (format nil "<p>~d - ~a: ~a</p>" code reason (escape (prin1-to-string extra)))
                                       code
                                       reason))

;; core server implementation (http request/repsonse loop and dispatching to handlers)

(defmethod find-handler ((s-http-server s-http-server) http-request)
  (let ((path (get-path http-request)))
    (loop :for context-binding :in (get-contexts s-http-server)
          :do (destructuring-bind (handler context &rest rest)
                  context-binding
                (declare (ignore handler rest))
                (if (string= path context :end1 (min (length context) (length path)))
                    (return-from find-handler context-binding))))))

(defmethod handle-one-http-request-response ((s-http-server s-http-server) http-connection)
  (with-slots (stream buffer id)
      http-connection
    (let* ((http-request
            (handler-case (parse-http-request stream buffer)
              (puri:uri-parse-error ()
                (logm s-http-server "[~d] Bad Request" id)
                (standard-http-html-error-response nil stream 400 "Bad Request" "Syntax Error")
                (finish-output stream)
                ;; retarget the error
                (error 'missing-http-request-line))))
           (handler (find-handler s-http-server http-request)))
      (when (get-debug-mode s-http-server) 
        (logm s-http-server "[~d] Handling ~s" id http-request))
      (multiple-value-bind (success response bytes)
          (if handler
              (if (get-debug-mode s-http-server)
                  (funcall (first handler) 
                           s-http-server (rest handler) http-request stream)
                (multiple-value-bind (result second third)
                    (ignore-errors (funcall (first handler) 
                                            s-http-server (rest handler) http-request stream))
                  (if result
                      (values result second third)
                    (progn 
                      (logm s-http-server "[~d] Handler ~s failed for ~s" id handler http-request)
                      (values t 500 (standard-http-html-error-response http-request stream 500 "Internal Server Error" 
                                                                       second))))))
            (progn
              (logm s-http-server "[~d] No handler found for ~s" id http-request)
              (values t 404 (standard-http-html-error-response http-request stream 404 "Resource Not Found" 
                                                               (get-path http-request)))))
        (declare (ignore success))
        (log-access s-http-server http-connection http-request response bytes))
      (finish-output stream)
      http-request)))

(defmethod handle-http-server-connection ((s-http-server s-http-server) http-connection)
  (setf (get-process http-connection) (s-sysdeps:current-process))
  (push http-connection (get-http-connections s-http-server))
  (unwind-protect
      (loop
       (if (get-debug-mode s-http-server)
           (unless (handler-case
                       (get-keep-alive (handle-one-http-request-response s-http-server http-connection))
                     #+lispworks(comm:socket-error () nil)
                     (missing-http-request-line () nil))
             (return))
         (unless (ignore-errors 
                   (get-keep-alive (handle-one-http-request-response s-http-server http-connection)))
           (return)))
       (setf (get-timestamp http-connection) (get-universal-time)))
    (ignore-errors 
      (close (get-stream http-connection) :abort t))
    (setf (get-process http-connection) nil
          (get-stream http-connection) nil
          (get-http-connections s-http-server) 
          (remove http-connection (get-http-connections s-http-server)))))

;; an S-HTTP-HANDLER is a function taking 4 arguments:
;; - the s-http-server object representing the server itself
;; - the handler binding (a list whose first element is always the context that matched)
;; - the current http-request object (containing request method, uri, version and the headers alist)
;; - the stream to the client (where the request line and headers are already consumed)
;; the handler should handle the request, outputing 3 things (in order):
;; - a response status line
;; - the response headers
;; - the contents
;; finally, the handler should return the following values:
;; - t if it was succesful in handling the request or nil otherwise
;; - the response code if a response was given, nil otherwise
;; - the number of bytes in the response if there was one, 0 or nil otherwise

;; the builtin handler

(defun s-http-server-handler (s-http-server handler http-request stream)
  "The builtin S-HTTP-SERVER testing/debugging handler returning a simple status/echo/snoop page"
  (logm s-http-server "Running builtin s-http-server handler")
  (let ((body (with-output-to-string (out)
                (format out "<p>Welcome to ~a</p>" *http-server-identification*)
                (format out "<p>This is ~s running on port ~d</p>" (get-name s-http-server) (get-port s-http-server))
                (format out "<p>S-HTTP-SERVER-HANDLER handling a ~a request for path ~s and version ~a</p>" 
                        (get-method http-request) (get-path http-request) (get-http-version http-request))
                (format out "<p>Server clock is ~a</p>" (s-utils:format-universal-time (get-universal-time)))
                (format out "<p>Server uptime is ~a</p>" (s-utils:format-duration (- (get-universal-time) 
                                                                                     (get-boot-time s-http-server))))
                (format out "<p>Remote host is ~s</p>" (s-sysdeps:get-socket-stream-property stream :remote-host))
                (format out "<p>Current thread is ~a</p>" (escape (prin1-to-string (s-sysdeps:current-process))))
                (format out "<p>Server thread is ~a</p>" (escape (prin1-to-string (get-server-process s-http-server))))
                (format out "<p>Open connections:</p><ul>~{<li>~a</li>~}</ul>" 
                        (mapcar #'(lambda (x) 
                                    (escape (prin1-to-string x)))
                                (get-http-connections s-http-server)))
                (format out "<p>Active handler binding is ~s</p>" handler)
                (format out "<p>Contexts:</p><table border='1' width='100%'>")
                (format out "<tr><th>Handler</th><th>Context</th><th>Parameters</th></tr>")
                (loop :for b :in (get-contexts s-http-server) 
                      :do (format out "<tr><td>~a</td><td>~a</td><td>~a</td></tr>" 
                                  (escape (prin1-to-string (first b))) 
                                  (second b) 
                                  (escape (prin1-to-string (rest (rest b))))))
                (format out "</table>")
                (format out "<p>Request Headers:</p>")
                (format out "<table border='1' width='100%'><tr><th>Key</th><th>Value</th></tr>")
                (loop :for (k . v) :in (get-headers http-request) 
                      :do (format out "<tr><td>~a</td><td>~a</td></tr>" k v))
                (format out "</table>"))))
    (values t 200 (standard-http-html-message-response http-request stream "S-HTTP-SERVER" body))))

;; the static resource (file server) handler

(defparameter +basic-mime-type-suffix-map+ 
  '(("html" . "text/html") ("htm" . "text/html") ("txt" . "text/plain")
    ("gif" . "image/gif") ("jpg" . "image/jpeg") ("jpeg" . "image/jpeg") ("png" . "image/png")))

(defparameter +known-mime.type-locations+ '("/etc/httpd/mime.types" "/etc/mime.types"))

(defparameter *mime-type-suffix-map* 
  (let ((map (make-hash-table :test 'equal)))
    (loop :for (suffix . mime-type) :in +basic-mime-type-suffix-map+ 
          :do (setf (gethash suffix map) mime-type))
    (loop :for location :in +known-mime.type-locations+
          :do (when (probe-file location)
                (with-open-file (in location)
                  (loop :for line = (read-line in nil)
                        :until (null line)
                        :unless (or (zerop (length line))
                                    (member (elt line 0) '(#\return #\linefeed #\#)))
                        :do (let* ((tokens (s-utils:tokens line :separators '(#\tab)))
                                   (mime-type (string-trim '(#\space) (first tokens)))
                                   (suffixes (s-utils:tokens (second tokens) :separators '(#\space))))
                              (loop :for suffix :in suffixes
                                    :do (setf (gethash suffix map) mime-type)))))))
    map))

(defun mime-type-for-pathname (pathname)
  (or (gethash (string-downcase (or (pathname-type pathname) "")) *mime-type-suffix-map*)
      "application/octet-stream"))

(defun compute-real-resource-pathname (root path context)
  (labels ((ensure-trailing-slash (str)
             (let ((len (length str)))
               (if (and (> len 0)
                        (char/= #\/ (elt str (1- len))))
                   (concatenate 'string str "/")
                 str))))
    (let* ((real-root (pathname root))
           (real-root-dir-components (rest (pathname-directory real-root)))
           (context-pathname (pathname (ensure-trailing-slash context)))
           (context-components (rest (pathname-directory context-pathname))) 
           (uri-pathname (pathname path))
           (uri-dir-components (rest (pathname-directory uri-pathname)))
           (difference (mismatch context-components uri-dir-components :test #'string=)))
      (setf uri-dir-components (when difference (subseq uri-dir-components difference)))
      (make-pathname :name (or (pathname-name uri-pathname) "index")
                     :type (or (pathname-type uri-pathname) "html")
                     :directory `(:absolute 
                                  ,@real-root-dir-components
                                  ,@uri-dir-components)))))

(defun host-static-resource (http-request stream resource-pathname)
  (let ((mime-type (mime-type-for-pathname resource-pathname)))    
    (with-open-file (in resource-pathname :element-type '(unsigned-byte 8))
      (write-http-response-status-line stream 200 "OK" (get-http-version http-request))
      (write-http-response-headers (standard-http-response-headers http-request
                                                                   :content-type mime-type 
                                                                   :content-length (file-length in))
                                   stream)
      (write-http-response-headers `(("Last-Modified" . ,(response-date (file-write-date in))))
                                   stream)
      (write-http-response-line "" stream)
      (s-utils:copy-stream in stream (make-array 4096 :element-type '(unsigned-byte 8)))
      (file-length in))))

(defun static-resource-handler (s-http-server handler http-request stream)
  "Host static resources from a document root"
  (destructuring-bind (context document-root)
      handler
    (let* ((path (get-path http-request))
           (resource-pathname (compute-real-resource-pathname document-root path context)))
      (if (probe-file resource-pathname)
          (progn
            (when (get-debug-mode s-http-server)
              (logm s-http-server "Serving ~s" resource-pathname))
            (values t 200 (host-static-resource http-request stream resource-pathname)))
        (progn
          (logm s-http-server "Failed to find ~s" resource-pathname)
          (values t 404 (standard-http-html-error-response http-request stream 404 "Resource Not Found" path)))))))

(defun single-static-resource-handler (s-http-server handler http-request stream)
  "Host a single fixed static resource"
  (destructuring-bind (context resource-pathname)
      handler
    (declare (ignore context))
    (if (probe-file resource-pathname)
        (progn
          (when (get-debug-mode s-http-server)
            (logm s-http-server "Serving ~s" resource-pathname))
          (values t 200 (host-static-resource http-request stream resource-pathname)))
      (progn
        (logm s-http-server "Failed to find ~s" resource-pathname)
        (values t 4040 (standard-http-html-error-response http-request stream 404 "Resource Not Found" 
                                                          (get-path http-request)))))))

;; the favicon handler

(defvar *favicon* nil "If not nil, the pathname to the favicon.ico")

(defun favicon-handler (s-http-server handler http-request stream)
  "Handle that annoying favicon.ico request in a more elegant way"
  (declare (ignore handler))
  (if (and *favicon* (pathnamep *favicon*) (probe-file *favicon*))
      (progn
        (when (get-debug-mode s-http-server)
          (logm s-http-server "Serving favicon ~s" *favicon*))
        (values t 200 (host-static-resource http-request stream *favicon*)))
      (progn
        (values t 404 (standard-http-html-error-response http-request stream 404 "Resource Not Found" 
                                                         (get-path http-request))))))

;; the redirect handler

(defun redirect-handler (s-http-server handler http-request stream)
  "This handler immediately redirects to another URL"
  (destructuring-bind (context url)
      handler
    (logm s-http-server "Redirecting ~s to ~s" context url)
    (write-http-response-status-line stream 302 "Moved Temporarily" (get-http-version http-request))
    (write-http-response-headers `(,@(standard-http-response-headers http-request 
                                                                     :content-type nil :content-length 0)
                                   ("Location" . ,url))
                                 stream)
    (write-http-response-line "" stream)
    (values t 302 0)))

;; basic authentication support with a wrapping handler

(defun request-header-value (http-request header-name)
  "Get the value of a named header of http-request"
  (cdr (assoc header-name (s-http-server:get-headers http-request) 
              :test #'string-equal)))

(defun decode-basic-authorization (authorization)
  "Decode the Base64 encoding of username:password returning (username . password)"
  (let* ((decoded-string (map 'simple-string #'code-char 
                              (with-input-from-string (in authorization)
                                (s-base64:decode-base64-bytes in))))
         (tokens (s-utils:tokens decoded-string :separators '(#\:))))
    (cons (first tokens) (second tokens))))

(defun authorized-p (basic-authorization authenticator)
  "Check whether a basic-authorization is authorized by authenticator"
  (let ((username-password (decode-basic-authorization basic-authorization)))
    (cond ((and (consp authenticator)
                (member username-password authenticator :test #'equal))
           t)
          ((and (or (and (symbolp authenticator)
                         (fboundp authenticator))
                    (functionp authenticator)))
           (funcall authenticator username-password))
          (t
           nil))))

(defun basic-authentication-required-http-response (http-request stream realm)
  (let* ((path (s-http-server:get-path http-request))
         (content (with-output-to-string (out)
                    (format out
                            "~a<html lang=\"en\"><head><title>~a</title></head><body><h1>~a: ~s</h1></body></html>" 
                            *doctype-html-401-strict* "Unauthorized" "401 Unauthorized" path)))
         (headers `(("WWW-Authenticate" . ,(format nil "Basic realm=~s" realm))
                    ,@(s-http-server:standard-http-response-headers http-request
                                                                    :content-type "text/html"
                                                                    :content-length (length content)))))
    (s-http-server:write-http-response-status-line stream "401" "Unauthorized" (get-http-version http-request))
    (s-http-server:write-http-response-headers headers stream)
    (s-http-server:write-http-response-line "" stream)
    (write-string content stream)))

(defun wrap-with-basic-authentication (handler-function &key arguments authenticator realm)
  "Creates and returns a new handler that wraps handler-function and argument with basic authentication.
Authenticator is either a dotted alist of usernames and passwords or a function accepting (username . password).
Realm is for use in the WWW-Authenticate header response." 
  (lambda (s-http-server handler http-request stream)
    (let* ((authorization-header (request-header-value http-request "Authorization"))
           (authorization-tokens (s-utils:tokens authorization-header :separators '(#\Space)))
           (authentication-type (first authorization-tokens))
           (authorization (second authorization-tokens)))
      (cond ((and authorization-header 
                  (string-equal authentication-type "Basic") 
                  (authorized-p authorization authenticator))
             (let ((user (first (decode-basic-authorization authorization))))
               (logm s-http-server "Basic Authentication succeeded for ~a" user)
               (push `(:user . ,user) (s-http-server:get-headers http-request))
               (funcall handler-function s-http-server `(,(first handler) ,@arguments) http-request stream))) 
            (t
             (basic-authentication-required-http-response http-request stream realm))))))

;;;; eof