path: root/elpa/simple-httpd-20191103.1446/simple-httpd.el

;;; simple-httpd.el --- pure elisp HTTP server

;; This is free and unencumbered software released into the public domain.

;; Author: Christopher Wellons <wellons@nullprogram.com>
;; URL: https://github.com/skeeto/emacs-http-server
;; Package-Version: 20191103.1446
;; Package-Commit: 22ce66ea43e0eadb9ec1d691a35d9695fc29cee6
;; Version: 1.5.1
;; Package-Requires: ((cl-lib "0.3"))

;;; Commentary:

;; Use `httpd-start' to start the web server. Files are served from
;; `httpd-root' on port `httpd-port' using `httpd-ip-family' at host
;; `httpd-host'. While the root can be changed at any time, the server
;; needs to be restarted in order for a port change to take effect.

;; Everything is performed by servlets, including serving
;; files. Servlets are enabled by setting `httpd-servlets' to true
;; (default). Servlets are four-parameter functions that begin with
;; "httpd/" where the trailing component specifies the initial path on
;; the server. For example, the function `httpd/hello-world' will be
;; called for the request "/hello-world" and "/hello-world/foo".

;; The default servlet `httpd/' is the one that serves files from
;; `httpd-root' and can be turned off through redefinition or setting
;; `httpd-serve-files' to nil. It is used even when `httpd-servlets'
;; is nil.

;; The four parameters for a servlet are process, URI path, GET/POST
;; arguments (alist), and the full request object (header
;; alist). These are ordered by general importance so that some can be
;; ignored. Two macros are provided to help with writing servlets.

;;  * `with-httpd-buffer' -- Creates a temporary buffer that is
;;    automatically served to the client at the end of the body.
;;    Additionally, `standard-output' is set to this output
;;    buffer. For example, this servlet says hello,

;;     (defun httpd/hello-world (proc path &rest args)
;;       (with-httpd-buffer proc "text/plain"
;;         (insert "hello, " (file-name-nondirectory path))))

;; This servlet be viewed at http://localhost:8080/hello-world/Emacs

;; * `defservlet' -- Similar to the above macro but totally hides the
;;   process object from the servlet itself. The above servlet can be
;;   re-written identically like so,

;;     (defservlet hello-world text/plain (path)
;;       (insert "hello, " (file-name-nondirectory path)))

;; Note that `defservlet' automatically sets `httpd-current-proc'. See
;; below.

;; The "function parameters" part can be left empty or contain up to
;; three parameters corresponding to the final three servlet
;; parameters. For example, a servlet that shows *scratch* and doesn't
;; need parameters,

;;     (defservlet scratch text/plain ()
;;       (insert-buffer-substring (get-buffer-create "*scratch*")))

;; A higher level macro `defservlet*' wraps this lower-level
;; `defservlet' macro, automatically binding variables to components
;; of the request. For example, this binds parts of the request path
;; and one query parameter. Request components not provided by the
;; client are bound to nil.

;;     (defservlet* packages/:package/:version text/plain (verbose)
;;       (insert (format "%s\n%s\n" package version))
;;       (princ (get-description package version))
;;       (when verbose
;;         (insert (format "%S" (get-dependencies package version)))))

;; It would be accessed like so,

;;     http://example.com/packages/foobar/1.0?verbose=1

;; Some support functions are available for servlets for more
;; customized responses.

;;   * `httpd-send-file'   -- serve a file with proper caching
;;   * `httpd-redirect'    -- redirect the browser to another url
;;   * `httpd-send-header' -- send custom headers
;;   * `httpd-error'       -- report an error to the client
;;   * `httpd-log'         -- log an object to *httpd*

;; Some of these functions require a process object, which isn't
;; passed to `defservlet' servlets. Use t in place of the process
;; argument to use `httpd-current-proc' (like `standard-output').

;; If you just need to serve static from some location under some
;; route on the server, use `httpd-def-file-servlet'. It expands into
;; a `defservlet' that serves files.

;;; History:

;; Version 1.5.1: improvements
;;   * Add `httpd-running-p'
;;   * Properly handle "Connection: close" and HTTP/1.0
;; Version 1.5.0: improvements
;;   * Drastically improved performance for large requests
;;   * More HTTP status codes
;; Version 1.4.6: fixes
;;   * Added httpd-serve-directory
;;   * Fix some encoding issues
;; Version 1.4.5: fixes
;;   * Update to cl-lib from cl
;; Version 1.4.4: features
;;   * Common Lisp &key-like defservlet* argument support
;;   * Fix up some defservlet* usage warnings.
;; Version 1.4.3: features
;;   * Add `httpd-discard-buffer'
;;   * Add `httpd-def-file-servlet'
;;   * Be more careful about not sending extra headers
;; Version 1.4.2: features, fixes
;;   * `defservlet*' macro
;; Version 1.4.1: small bug fixes, one feature
;;   * All mime-type parameters now accept string designators
;;   * Documentation update
;; Version 1.4.0: features, API change, and fixes
;;   * Removed httpd-send-buffer; httpd-send-header now does this implicitly
;;   * httpd-send-header now accepts keywords instead
;;   * Fix httpd-clean-path in Windows
;;   * Fix a content-length bug
;;   * defservlet fontification
;; Version 1.3.1: features and fixes
;;   * Set `standard-output' in `with-httpd-buffer'
;; Version 1.3.0: security fix
;;   * Fix path expansion security issue
;;   * Fix coding system (don't default)
;; Version 1.2.4: fixes
;;   * Handle large POSTs
;;   * Fix date strings

;;; Code:

(require 'cl-lib)
(require 'pp)
(require 'url-util)

(defgroup simple-httpd nil
  "A simple web server."
  :group 'comm)

(defcustom httpd-ip-family 'ipv4
  "Web server IP family used by `make-network-process'."
  :group 'simple-httpd
  :type 'symbol)

(defcustom httpd-host nil
  "Web server host name used by `make-network-process'."
  :group 'simple-httpd
  :type '(choice (const nil) (const local) string))

(defcustom httpd-port 8080
  "Web server port."
  :group 'simple-httpd
  :type 'integer)

(defcustom httpd-root "~/public_html"
  "Web server file root."
  :group 'simple-httpd
  :type 'directory)

(defcustom httpd-serve-files t
  "Enable serving files from `httpd-root'."
  :group 'simple-httpd
  :type 'boolean)

(defcustom httpd-listings t
  "If true, serve directory listings."
  :group 'simple-httpd
  :type 'boolean)

(defcustom httpd-servlets t
  "Enable servlets."
  :group 'simple-httpd
  :type 'boolean)

(defcustom httpd-show-backtrace-when-error nil
  "If true, show backtrace on error page."
  :group 'simple-httpd
  :type 'boolean)

(defcustom httpd-start-hook nil
  "Hook to run when the server has started."
  :group 'simple-httpd
  :type 'hook)

(defcustom httpd-stop-hook nil
  "Hook to run when the server has stopped."
  :group 'simple-httpd
  :type 'hook)

(defvar httpd-server-name (format "simple-httpd (Emacs %s)" emacs-version)
  "String to use in the Server header.")

(defvar httpd-mime-types
  '(("png"  . "image/png")
    ("gif"  . "image/gif")
    ("jpg"  . "image/jpeg")
    ("jpeg" . "image/jpeg")
    ("tif"  . "image/tif")
    ("tiff" . "image/tiff")
    ("ico"  . "image/x-icon")
    ("svg"  . "image/svg+xml")
    ("css"  . "text/css; charset=utf-8")
    ("htm"  . "text/html; charset=utf-8")
    ("html" . "text/html; charset=utf-8")
    ("xml"  . "text/xml; charset=utf-8")
    ("rss"  . "text/xml; charset=utf-8")
    ("atom" . "text/xml; charset=utf-8")
    ("txt"  . "text/plain; charset=utf-8")
    ("el"   . "text/plain; charset=utf-8")
    ("js"   . "text/javascript; charset=utf-8")
    ("md"   . "text/x-markdown; charset=utf-8")
    ("gz"   . "application/octet-stream")
    ("ps"   . "application/postscript")
    ("eps"  . "application/postscript")
    ("pdf"  . "application/pdf")
    ("tar"  . "application/x-tar")
    ("zip"  . "application/zip")
    ("mp3"  . "audio/mpeg")
    ("wav"  . "audio/x-wav")
    ("flac" . "audio/flac")
    ("spx"  . "audio/ogg")
    ("oga"  . "audio/ogg")
    ("ogg"  . "audio/ogg")
    ("ogv"  . "video/ogg")
    ("mp4"  . "video/mp4")
    ("mkv"  . "video/x-matroska")
    ("webm" . "video/webm"))
  "MIME types for headers.")

(defvar httpd-indexes
  '("index.html"
    "index.htm"
    "index.xml")
  "File served by default when accessing a directory.")

(defvar httpd-status-codes
  '((100 . "Continue")
    (101 . "Switching Protocols")
    (102 . "Processing")
    (200 . "OK")
    (201 . "Created")
    (202 . "Accepted")
    (203 . "Non-authoritative Information")
    (204 . "No Content")
    (205 . "Reset Content")
    (206 . "Partial Content")
    (207 . "Multi-Status")
    (208 . "Already Reported")
    (226 . "IM Used")
    (300 . "Multiple Choices")
    (301 . "Moved Permanently")
    (302 . "Found")
    (303 . "See Other")
    (304 . "Not Modified")
    (305 . "Use Proxy")
    (307 . "Temporary Redirect")
    (308 . "Permanent Redirect")
    (400 . "Bad Request")
    (401 . "Unauthorized")
    (402 . "Payment Required")
    (403 . "Forbidden")
    (404 . "Not Found")
    (405 . "Method Not Allowed")
    (406 . "Not Acceptable")
    (407 . "Proxy Authentication Required")
    (408 . "Request Timeout")
    (409 . "Conflict")
    (410 . "Gone")
    (411 . "Length Required")
    (412 . "Precondition Failed")
    (413 . "Payload Too Large")
    (414 . "Request-URI Too Long")
    (415 . "Unsupported Media Type")
    (416 . "Requested Range Not Satisfiable")
    (417 . "Expectation Failed")
    (418 . "I'm a teapot")
    (421 . "Misdirected Request")
    (422 . "Unprocessable Entity")
    (423 . "Locked")
    (424 . "Failed Dependency")
    (426 . "Upgrade Required")
    (428 . "Precondition Required")
    (429 . "Too Many Requests")
    (431 . "Request Header Fields Too Large")
    (444 . "Connection Closed Without Response")
    (451 . "Unavailable For Legal Reasons")
    (499 . "Client Closed Request")
    (500 . "Internal Server Error")
    (501 . "Not Implemented")
    (502 . "Bad Gateway")
    (503 . "Service Unavailable")
    (504 . "Gateway Timeout")
    (505 . "HTTP Version Not Supported")
    (506 . "Variant Also Negotiates")
    (507 . "Insufficient Storage")
    (508 . "Loop Detected")
    (510 . "Not Extended")
    (511 . "Network Authentication Required")
    (599 . "Network Connect Timeout Error"))
  "HTTP status codes.")

(defvar httpd-html
  '((403 . "<!DOCTYPE html>
<html><head>
<title>403 Forbidden</title>
</head><body>
<h1>Forbidden</h1>
<p>The requested URL is forbidden.</p>
<pre>%s</pre>
</body></html>")
    (404 . "<!DOCTYPE html>
<html><head>
<title>404 Not Found</title>
</head><body>
<h1>Not Found</h1>
<p>The requested URL was not found on this server.</p>
<pre>%s</pre>
</body></html>")
    (500 . "<!DOCTYPE html>
<html><head>
<title>500 Internal Error</title>
</head><body>
<h1>500 Internal Error</h1>
<p>Internal error when handling this request.</p>
<pre>%s</pre>
</body></html>"))
  "HTML for various errors.")

;; User interface

;;;###autoload
(defun httpd-start ()
  "Start the web server process. If the server is already
running, this will restart the server. There is only one server
instance per Emacs instance."
  (interactive)
  (httpd-stop)
  (httpd-log `(start ,(current-time-string)))
  (make-network-process
   :name     "httpd"
   :service  httpd-port
   :server   t
   :host     httpd-host
   :family   httpd-ip-family
   :filter   'httpd--filter
   :coding   'binary
   :log      'httpd--log)
  (run-hooks 'httpd-start-hook))

;;;###autoload
(defun httpd-stop ()
  "Stop the web server if it is currently running, otherwise do nothing."
  (interactive)
  (when (process-status "httpd")
    (delete-process "httpd")
    (httpd-log `(stop ,(current-time-string)))
    (run-hooks 'httpd-stop-hook)))

;;;###autoload
(defun httpd-running-p ()
  "Return non-nil if the simple-httpd server is running."
  (not (null (process-status "httpd"))))

;;;###autoload
(defun httpd-serve-directory (directory)
  "Start the web server with given `directory' as `httpd-root'."
  (interactive "DServe directory: \n")
  (setf httpd-root directory)
  (httpd-start)
  (message "Started simple-httpd on %s:%d, serving: %s"
           (cl-case httpd-host
             ((nil) "0.0.0.0")
             ((local) "localhost")
             (otherwise httpd-host)) httpd-port directory))

(defun httpd-batch-start ()
  "Never returns, holding the server open indefinitely for batch mode.
Logs are redirected to stdout. To use, invoke Emacs like this:
emacs -Q -batch -l simple-httpd.elc -f httpd-batch-start"
  (if (not noninteractive)
      (error "Only use `httpd-batch-start' in batch mode!")
    (httpd-start)
    (defalias 'httpd-log 'pp)
    (while t (sleep-for 60))))

;; Utility

(defun httpd-date-string (&optional date)
  "Return an HTTP date string (RFC 1123)."
  (format-time-string "%a, %e %b %Y %T GMT" date t))

(defun httpd-etag (file)
  "Compute the ETag for FILE."
  (concat "\"" (substring (sha1 (prin1-to-string (file-attributes file))) -16)
          "\""))

(defun httpd--stringify (designator)
  "Turn a string designator into a string."
  (let ((string (format "%s" designator)))
    (if (keywordp designator)
        (substring string 1)
      string)))

;; Networking code

(defun httpd--connection-close-p (request)
  "Return non-nil if the client requested \"connection: close\"."
  (or (equal '("close") (cdr (assoc "Connection" request)))
      (equal '("HTTP/1.0") (cddr (assoc "GET" request)))))

(defun httpd--filter (proc chunk)
  "Runs each time client makes a request."
  (with-current-buffer (process-get proc :request-buffer)
    (setf (point) (point-max))
    (insert chunk)
    (let ((request (process-get proc :request)))
      (unless request
        (when (setf request (httpd-parse))
          (delete-region (point-min) (point))
          (process-put proc :request request)))
      (when request
        (let ((content-length (cadr (assoc "Content-Length" request))))
          (when (or (null content-length)
                    (= (buffer-size) (string-to-number content-length)))
            (let* ((content (buffer-string))
                   (uri (cl-cadar request))
                   (parsed-uri (httpd-parse-uri (concat uri)))
                   (uri-path (httpd-unhex (nth 0 parsed-uri)))
                   (uri-query (append (nth 1 parsed-uri)
                                      (httpd-parse-args content)))
                   (servlet (httpd-get-servlet uri-path)))
              (erase-buffer)
              (process-put proc :request nil)
              (setf request (nreverse (cons (list "Content" content)
                                            (nreverse request))))
              (httpd-log `(request (date ,(httpd-date-string))
                                   (address ,(car (process-contact proc)))
                                   (get ,uri-path)
                                   ,(cons 'headers request)))
              (if (null servlet)
                  (httpd--error-safe proc 404)
                (condition-case error-case
                    (funcall servlet proc uri-path uri-query request)
                  (error (httpd--error-safe proc 500 error-case))))
              (when (httpd--connection-close-p request)
                (process-send-eof proc)))))))))

(defun httpd--log (server proc message)
  "Runs each time a new client connects."
  (with-current-buffer (generate-new-buffer " *httpd-client*")
    (process-put proc :request-buffer (current-buffer)))
  (set-process-sentinel proc #'httpd--sentinel)
  (httpd-log (list 'connection (car (process-contact proc)))))

(defun httpd--sentinel (proc message)
  "Runs when a client closes the connection."
  (unless (string-match-p "^open " message)
    (let ((buffer (process-get proc :request-buffer)))
      (when buffer
        (kill-buffer buffer)))))

;; Logging

(defun httpd-log (item)
  "Pretty print a lisp object to the log."
  (with-current-buffer (get-buffer-create "*httpd*")
    (setf buffer-read-only nil)
    (let ((follow (= (point) (point-max))))
      (save-excursion
        (goto-char (point-max))
        (pp item (current-buffer)))
      (if follow (goto-char (point-max))))
    (setf truncate-lines t
          buffer-read-only t)
    (set-buffer-modified-p nil)))

;; Servlets

(defvar httpd-current-proc nil
  "The process object currently in use.")

(defvar httpd--header-sent nil
  "Buffer-local variable indicating if the header has been sent.")
(make-variable-buffer-local 'httpd--header-sent)

(defun httpd-resolve-proc (proc)
  "Return the correct process to use. This handles `httpd-current-proc'."
  (if (eq t proc) httpd-current-proc proc))

(defmacro with-httpd-buffer (proc mime &rest body)
  "Create a temporary buffer, set it as the current buffer, and,
at the end of body, automatically serve it to an HTTP client with
an HTTP header indicating the specified MIME type. Additionally,
`standard-output' is set to this output buffer and
`httpd-current-proc' is set to PROC."
  (declare (indent defun))
  (let ((proc-sym (make-symbol "--proc--")))
    `(let ((,proc-sym ,proc))
       (with-temp-buffer
         (setf major-mode 'httpd-buffer)
         (let ((standard-output (current-buffer))
               (httpd-current-proc ,proc-sym))
           ,@body)
         (unless httpd--header-sent
           (httpd-send-header ,proc-sym ,mime 200))))))

(defun httpd-discard-buffer ()
  "Don't respond using current server buffer (`with-httpd-buffer').
Returns a process for future response."
  (when (eq major-mode 'httpd-buffer) (setf httpd--header-sent t))
  httpd-current-proc)

(defmacro defservlet (name mime path-query-request &rest body)
  "Defines a simple httpd servelet. The servlet runs in a
temporary buffer which is automatically served to the client
along with a header.

A servlet that serves the contents of *scratch*,

    (defservlet scratch text/plain ()
      (insert-buffer-substring (get-buffer-create \"*scratch*\")))

A servlet that says hello,

    (defservlet hello-world text/plain (path)
      (insert \"hello, \" (file-name-nondirectory path))))"
  (declare (indent defun))
  (let ((proc-sym (make-symbol "proc"))
        (fname (intern (concat "httpd/" (symbol-name name)))))
    `(defun ,fname (,proc-sym ,@path-query-request &rest ,(cl-gensym))
       (with-httpd-buffer ,proc-sym ,(httpd--stringify mime)
         ,@body))))

(defun httpd-parse-endpoint (symbol)
  "Parse an endpoint definition template for use with `defservlet*'."
  (cl-loop for item in (split-string (symbol-name symbol) "/")
           for n upfrom 0
           when (and (> (length item) 0) (eql (aref item 0) ?:))
           collect (cons (intern (substring item 1)) n) into vars
           else collect item into path
           finally
           (cl-return
            (cl-values (intern (mapconcat #'identity path "/")) vars))))

(defvar httpd-path nil
  "Anaphoric variable for `defservlet*'.")

(defvar httpd-query nil
  "Anaphoric variable for `defservlet*'.")

(defvar httpd-request nil
  "Anaphoric variable for `defservlet*'.")

(defvar httpd-split-path nil
  "Anaphoric variable for `defservlet*'.")

(defmacro defservlet* (endpoint mime args &rest body)
  "Like `defservlet', but automatically bind variables/arguments
to the request. Trailing components of the ENDPOINT can be bound
by prefixing these components with a colon, acting like a template.

    (defservlet* packages/:package/:version text/plain (verbose)
      (insert (format \"%s\\n%s\\n\" package version))
      (princ (get-description package version))
      (when verbose
        (insert (format \"%S\" (get-dependencies package version)))))

When accessed from this URL,

    http://example.com/packages/foobar/1.0?verbose=1

the variables package, version, and verbose will be bound to the
associated components of the URL. Components not provided are
bound to nil. The query arguments can use the Common Lisp &key
form (variable default provided-p).

    (defservlet* greeting/:name text/plain ((greeting \"hi\" greeting-p))
      (princ (format \"%s, %s (provided: %s)\" greeting name greeting-p)))

The original path, query, and request can be accessed by the
anaphoric special variables `httpd-path', `httpd-query', and
`httpd-request'."
  (declare (indent defun))
  (let ((path-lexical (cl-gensym))
        (query-lexical (cl-gensym))
        (request-lexical (cl-gensym)))
    (cl-multiple-value-bind (path vars) (httpd-parse-endpoint endpoint)
      `(defservlet ,path ,mime (,path-lexical ,query-lexical ,request-lexical)
         (let ((httpd-path ,path-lexical)
               (httpd-query ,query-lexical)
               (httpd-request ,request-lexical)
               (httpd-split-path (split-string
                                  (substring ,path-lexical 1) "/")))
           (let ,(cl-loop for (var . pos) in vars
                          for extract =
                          `(httpd-unhex (nth ,pos httpd-split-path))
                          collect (list var extract))
             (let ,(cl-loop for arg in args
                            for has-default = (listp arg)
                            for has-default-p = (and has-default
                                                     (= 3 (length arg)))
                            for arg-name = (symbol-name
                                            (if has-default (cl-first arg) arg))
                            when has-default collect
                            (list (cl-first arg)
                                  `(let ((value (assoc ,arg-name httpd-query)))
                                     (if value
                                         (cl-second value)
                                       ,(cl-second arg))))
                            else collect
                            (list arg `(cl-second
                                        (assoc ,arg-name httpd-query)))
                            when has-default-p collect
                            (list (cl-third arg)
                                  `(not (null (assoc ,arg-name httpd-query)))))
               ,@body)))))))

(font-lock-add-keywords
 'emacs-lisp-mode
 '(("(\\<\\(defservlet\\*?\\)\\> +\\([^ ()]+\\) +\\([^ ()]+\\)"
    (1 'font-lock-keyword-face)
    (2 'font-lock-function-name-face)
    (3 'font-lock-type-face))))

(defmacro httpd-def-file-servlet (name root)
  "Defines a servlet that serves files from ROOT under the route NAME.

    (httpd-def-file-servlet my/www \"/var/www/\")

Automatically handles redirects and uses `httpd-serve-root' to
actually serve up files."
  (let* ((short-root (directory-file-name (symbol-name name)))
         (path-root (concat short-root "/"))
         (chop (length path-root)))
    `(defservlet ,name nil (uri-path query request)
       (setf httpd--header-sent t) ; Don't actually use this temp buffer
       (if (= (length uri-path) ,chop)
           (httpd-redirect t ,path-root)
         (let ((path (substring uri-path ,chop)))
           (httpd-serve-root t ,root path request))))))

;; Request parsing

(defun httpd--normalize-header (header)
  "Destructively capitalize the components of HEADER."
  (mapconcat #'capitalize (split-string header "-") "-"))

(defun httpd-parse ()
  "Parse HTTP header in current buffer into association list.
Leaves the point at the start of the request content. Returns nil
if it failed to parse a complete HTTP header."
  (setf (point) (point-min))
  (when (looking-at "\\([^ ]+\\) +\\([^ ]+\\) +\\([^\r]+\\)\r\n")
    (let ((method (match-string 1))
          (path (decode-coding-string (match-string 2) 'iso-8859-1))
          (version (match-string 3))
          (headers ()))
      (setf (point) (match-end 0))
      (while (looking-at "\\([-!#-'*+.0-9A-Z^_`a-z|~]+\\): *\\([^\r]+\\)\r\n")
        (setf (point) (match-end 0))
        (let ((name (match-string 1))
              (value (match-string 2)))
          (push (list (httpd--normalize-header name)
                      (decode-coding-string value 'iso-8859-1)) headers)))
      (when (looking-at "\r\n")
        (setf (point) (match-end 0))
        (cons (list method path version) (nreverse headers))))))

(defun httpd-unhex (str)
  "Fully decode the URL encoding in STR (including +'s)."
  (when str
    (let ((nonplussed (replace-regexp-in-string (regexp-quote "+") " " str)))
      (decode-coding-string (url-unhex-string nonplussed t) 'utf-8))))

(defun httpd-parse-args (argstr)
  "Parse a string containing URL encoded arguments."
  (unless (zerop (length argstr))
    (mapcar (lambda (str)
              (mapcar 'httpd-unhex (split-string str "=")))
            (split-string argstr "&"))))

(defun httpd-parse-uri (uri)
  "Split a URI into its components.
The first element of the return value is the script path, the
second element is an alist of variable/value pairs, and the third
element is the fragment."
  (let ((p1 (string-match (regexp-quote "?") uri))
        (p2 (string-match (regexp-quote "#") uri))
        retval)
    (push (if p2 (httpd-unhex (substring uri (1+ p2)))) retval)
    (push (if p1 (httpd-parse-args (substring uri (1+ p1) p2))) retval)
    (push (substring uri 0 (or p1 p2)) retval)))

(defun httpd-escape-html-buffer ()
  "Escape current buffer contents to be safe for inserting into HTML."
  (setf (point) (point-min))
  (while (search-forward-regexp "[<>&]" nil t)
    (replace-match
     (cl-case (aref (match-string 0) 0)
       (?< "&lt;")
       (?> "&gt;")
       (?& "&amp;")))))

(defun httpd-escape-html (string)
  "Escape STRING so that it's safe to insert into an HTML document."
  (with-temp-buffer
    (insert string)
    (httpd-escape-html-buffer)
    (buffer-string)))

;; Path handling

(defun httpd-status (path)
  "Determine status code for PATH."
  (cond
   ((not (file-exists-p path))   404)
   ((not (file-readable-p path)) 403)
   ((and (file-directory-p path) (not httpd-listings)) 403)
   (200)))

(defun httpd-clean-path (path)
  "Clean dangerous .. from PATH and remove the leading slash."
  (let* ((sep (if (member system-type '(windows-nt ms-dos)) "[/\\]" "/"))
         (split (delete ".." (split-string path sep)))
         (unsplit (mapconcat 'identity (delete "" split) "/")))
    (concat "./" unsplit)))

(defun httpd-gen-path (path &optional root)
  "Translate GET to secure path in ROOT (`httpd-root')."
  (let ((clean (expand-file-name (httpd-clean-path path) (or root httpd-root))))
    (if (file-directory-p clean)
        (let* ((dir (file-name-as-directory clean))
               (indexes (cl-mapcar (apply-partially 'concat dir) httpd-indexes))
               (existing (cl-remove-if-not 'file-exists-p indexes)))
          (or (car existing) dir))
      clean)))

(defun httpd-get-servlet (uri-path)
  "Determine the servlet to be executed for URI-PATH."
  (if (not httpd-servlets)
      'httpd/
    (cl-labels ((cat (x)
                  (concat "httpd/" (mapconcat 'identity (reverse x) "/"))))
      (let ((parts (cdr (split-string (directory-file-name uri-path) "/"))))
        (or
         (cl-find-if 'fboundp (mapcar 'intern-soft
                                      (cl-maplist #'cat (reverse parts))))
         'httpd/)))))

(defun httpd-serve-root (proc root uri-path &optional request)
  "Securely serve a file from ROOT from under PATH."
  (let* ((path (httpd-gen-path uri-path root))
         (status (httpd-status path)))
    (cond
     ((not (= status 200))    (httpd-error          proc status))
     ((file-directory-p path) (httpd-send-directory proc path uri-path))
     (t                       (httpd-send-file      proc path request)))))

(defun httpd/ (proc uri-path query request)
  "Default root servlet which serves files when httpd-serve-files is T."
  (if (and httpd-serve-files httpd-root)
      (httpd-serve-root proc httpd-root uri-path request)
    (httpd-error proc 403)))

(defun httpd-get-mime (ext)
  "Fetch MIME type given the file extention."
  (or (and ext (cdr (assoc (downcase ext) httpd-mime-types)))
      "application/octet-stream"))

;; Data sending functions

(defun httpd-send-header (proc mime status &rest header-keys)
  "Send an HTTP header with given MIME type and STATUS, followed
by the current buffer. If PROC is T use the `httpd-current-proc'
as the process.

Extra headers can be sent by supplying them like keywords, i.e.

 (httpd-send-header t \"text/plain\" 200 :X-Powered-By \"simple-httpd\")"
  (let ((status-str (cdr (assq status httpd-status-codes)))
        (headers `(("Server" . ,httpd-server-name)
                   ("Date" . ,(httpd-date-string))
                   ("Connection" . "keep-alive")
                   ("Content-Type" . ,(httpd--stringify mime))
                   ("Content-Length" . ,(httpd--buffer-size)))))
    (unless httpd--header-sent
      (setf httpd--header-sent t)
      (with-temp-buffer
        (insert (format "HTTP/1.1 %d %s\r\n" status status-str))
        (cl-loop for (header value) on header-keys by #'cddr
                 for header-name = (substring (symbol-name header) 1)
                 for value-name = (format "%s" value)
                 collect (cons header-name value-name) into extras
                 finally (setf headers (nconc headers extras)))
        (dolist (header headers)
          (insert (format "%s: %s\r\n" (car header) (cdr header))))
        (insert "\r\n")
        (process-send-region (httpd-resolve-proc proc)
                             (point-min) (point-max)))
      (process-send-region (httpd-resolve-proc proc)
                           (point-min) (point-max)))))

(defun httpd-redirect (proc path &optional code)
  "Redirect the client to PATH (default 301). If PROC is T use
the `httpd-current-proc' as the process."
  (httpd-log (list 'redirect path))
  (httpd-discard-buffer)
  (with-temp-buffer
    (httpd-send-header proc "text/plain" (or code 301) :Location path)))

(defun httpd-send-file (proc path &optional req)
  "Serve file to the given client.  If PROC is T use the
`httpd-current-proc' as the process."
  (httpd-discard-buffer)
  (let ((req-etag (cadr (assoc "If-None-Match" req)))
        (etag (httpd-etag path))
        (mtime (httpd-date-string (nth 4 (file-attributes path)))))
    (if (equal req-etag etag)
        (with-temp-buffer
          (httpd-log `(file ,path not-modified))
          (httpd-send-header proc "text/plain" 304))
      (httpd-log `(file ,path))
      (with-temp-buffer
        (set-buffer-multibyte nil)
        (insert-file-contents-literally path)
        (httpd-send-header proc (httpd-get-mime (file-name-extension path))
                           200 :Last-Modified mtime :ETag etag)))))

(defun httpd-send-directory (proc path uri-path)
  "Serve a file listing to the client. If PROC is T use the
`httpd-current-proc' as the process."
  (httpd-discard-buffer)
  (let ((title (concat "Directory listing for "
                       (url-insert-entities-in-string uri-path))))
    (if (equal "/" (substring uri-path -1))
        (with-temp-buffer
          (httpd-log `(directory ,path))
          (insert "<!DOCTYPE html>\n")
          (insert "<html>\n<head><title>" title "</title></head>\n")
          (insert "<body>\n<h2>" title "</h2>\n<hr/>\n<ul>")
          (dolist (file (directory-files path))
            (unless (eq ?. (aref file 0))
              (let* ((full (expand-file-name file path))
                     (tail (if (file-directory-p full) "/" ""))
                     (f (url-insert-entities-in-string file))
                     (l (url-hexify-string file)))
                (insert (format "<li><a href=\"%s%s\">%s%s</a></li>\n"
                                l tail f tail)))))
          (insert "</ul>\n<hr/>\n</body>\n</html>")
          (httpd-send-header proc "text/html; charset=utf-8" 200))
      (httpd-redirect proc (concat uri-path "/")))))

(defun httpd--buffer-size (&optional buffer)
  "Get the buffer size in bytes."
  (let ((orig enable-multibyte-characters)
        (size 0))
    (with-current-buffer (or buffer (current-buffer))
      (set-buffer-multibyte nil)
      (setf size (buffer-size))
      (if orig (set-buffer-multibyte orig)))
    size))

(defun httpd-error (proc status &optional info)
  "Send an error page appropriate for STATUS to the client,
optionally inserting object INFO into page. If PROC is T use the
`httpd-current-proc' as the process."
  (httpd-discard-buffer)
  (httpd-log `(error ,status ,info))
  (with-temp-buffer
    (let ((html (or (cdr (assq status httpd-html)) ""))
          (contents
           (if (not info)
               ""
             (with-temp-buffer
               (let ((standard-output (current-buffer)))
                 (insert "error: ")
                 (princ info)
                 (insert "\n")
                 (when httpd-show-backtrace-when-error
                   (insert "backtrace: ")
                   (princ (backtrace))
                   (insert "\n"))
                 (httpd-escape-html-buffer)
                 (buffer-string))))))
      (insert (format html contents)))
    (httpd-send-header proc "text/html" status)))

(defun httpd--error-safe (&rest args)
  "Call httpd-error and report failures to *httpd*."
  (condition-case error-case
      (apply #'httpd-error args)
    (error (httpd-log `(hard-error ,error-case)))))

(provide 'simple-httpd)

;;; simple-httpd.el ends here