997 lines
36 KiB
EmacsLisp
997 lines
36 KiB
EmacsLisp
;;; simple-httpd.el --- Pure Elisp HTTP server -*- lexical-binding: t -*-
|
|
|
|
;; This is free and unencumbered software released into the public domain.
|
|
|
|
;; Author: Christopher Wellons <wellons@nullprogram.com>
|
|
;; Maintainer: Philip Kaludercic <philipk@posteo.net>, Daniel Mendler <mail@daniel-mendler.de>
|
|
;; URL: https://github.com/skeeto/emacs-http-server
|
|
;; Package-Version: 20260623.1110
|
|
;; Package-Revision: ceb208f96601
|
|
;; Package-Requires: ((emacs "29.1") (compat "31"))
|
|
;; Keywords: network, comm
|
|
|
|
;;; 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.
|
|
|
|
;; * `httpd-with-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)
|
|
;; (httpd-with-buffer proc "text/plain"
|
|
;; (insert "hello, " (file-name-nondirectory path))))
|
|
|
|
;; This servlet be viewed at http://localhost:8080/hello-world/Emacs
|
|
|
|
;; * `httpd-servlet' -- 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,
|
|
|
|
;; (httpd-servlet hello-world text/plain (path)
|
|
;; (insert "hello, " (file-name-nondirectory path)))
|
|
|
|
;; Note that `httpd-servlet' 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,
|
|
|
|
;; (httpd-servlet scratch text/plain ()
|
|
;; (insert-buffer-substring (get-buffer-create "*scratch*")))
|
|
|
|
;; A higher level macro `httpd-servlet*' wraps this lower-level
|
|
;; `httpd-servlet' 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.
|
|
|
|
;; (httpd-servlet* 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 the `httpd-log-buffer'
|
|
|
|
;; Some of these functions require a process object, which isn't
|
|
;; passed to `httpd-servlet' 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-file-servlet'. It expands into
|
|
;; a `httpd-servlet' that serves files.
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'subr-x))
|
|
(require 'cl-lib)
|
|
(require 'pp)
|
|
(require 'url-util)
|
|
(require 'compat)
|
|
|
|
(defgroup simple-httpd nil
|
|
"A simple web server."
|
|
:link '(url-link :tag "Website" "https://github.com/skeeto/emacs-http-server")
|
|
:link '(emacs-library-link :tag "Library Source" "simple-httpd.el")
|
|
:group 'network
|
|
:group 'comm
|
|
:group 'web
|
|
:prefix "httpd-")
|
|
|
|
(defcustom httpd-ip-family 'ipv4
|
|
"Web server IP family used by `make-network-process'."
|
|
:type 'symbol)
|
|
|
|
(defcustom httpd-host nil
|
|
"Web server host name used by `make-network-process'."
|
|
:type '(choice (const nil) (const local) string))
|
|
|
|
(defcustom httpd-port 8080
|
|
"Web server port."
|
|
:type 'natnum)
|
|
|
|
(defcustom httpd-root "~/public_html"
|
|
"Web server file root."
|
|
:type '(choice (const nil) directory))
|
|
|
|
(defcustom httpd-serve-files t
|
|
"Enable serving files from `httpd-root'."
|
|
:type 'boolean)
|
|
|
|
(defcustom httpd-listings t
|
|
"If true, serve directory listings."
|
|
:type 'boolean)
|
|
|
|
(defcustom httpd-servlets t
|
|
"Enable servlets."
|
|
:type 'boolean)
|
|
|
|
(defcustom httpd-log-buffer "*httpd*"
|
|
"Buffer for log messages.
|
|
Set to nil to disable logging."
|
|
:type '(choice (const nil) string))
|
|
|
|
(defcustom httpd-show-backtrace-when-error nil
|
|
"If true, show backtrace on error page."
|
|
:type 'boolean)
|
|
|
|
(defcustom httpd-start-hook nil
|
|
"Hook to run when the server has started."
|
|
:type 'hook)
|
|
|
|
(defcustom httpd-stop-hook nil
|
|
"Hook to run when the server has stopped."
|
|
:type 'hook)
|
|
|
|
(defcustom httpd-filter-functions nil
|
|
"Functions called with request as argument, should return modified request."
|
|
:type 'hook)
|
|
|
|
(defcustom httpd-server-name (format "simple-httpd (Emacs %s)" emacs-version)
|
|
"String to use in the Server header."
|
|
:type '(choice (const nil) string))
|
|
|
|
(defvar httpd-mime-types
|
|
'(("png" . "image/png")
|
|
("gif" . "image/gif")
|
|
("jpg" . "image/jpeg")
|
|
("jpeg" . "image/jpeg")
|
|
("tif" . "image/tif")
|
|
("tiff" . "image/tiff")
|
|
("webp" . "image/webp")
|
|
("ico" . "image/x-icon")
|
|
("svg" . "image/svg+xml")
|
|
("css" . "text/css")
|
|
("htm" . "text/html")
|
|
("html" . "text/html")
|
|
("xml" . "text/xml")
|
|
("rss" . "text/xml")
|
|
("atom" . "text/xml")
|
|
("txt" . "text/plain")
|
|
("el" . "text/plain")
|
|
("js" . "text/javascript")
|
|
("md" . "text/markdown")
|
|
("org" . "text/org")
|
|
("gz" . "application/octet-stream")
|
|
("ps" . "application/postscript")
|
|
("eps" . "application/postscript")
|
|
("pdf" . "application/pdf")
|
|
("tar" . "application/x-tar")
|
|
("zip" . "application/zip")
|
|
("wasm" . "application/wasm")
|
|
("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
|
|
'((404 . "<!DOCTYPE html>
|
|
<html><head><title>%2$s %3$s</title></head><body>
|
|
<h1>%2$s %3$s</h1>
|
|
<p>The requested URL was not found on this server.</p>
|
|
<pre>%1$s</pre></body></html>")
|
|
(t . "<!DOCTYPE html>
|
|
<html><head><title>%2$s %3$s</title></head><body>
|
|
<h1>%2$s %3$s</h1>
|
|
<p>An error occurred.</p>
|
|
<pre>%1$s</pre>
|
|
</body></html>"))
|
|
"HTML for various errors.")
|
|
|
|
(defvar httpd--server nil
|
|
"Server process.")
|
|
|
|
(defvar httpd--clients nil
|
|
"Client processes.")
|
|
|
|
;; 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 ,(httpd-date-string)))
|
|
(setq httpd--server
|
|
(make-network-process
|
|
:name "httpd"
|
|
:service httpd-port
|
|
:server t
|
|
:host httpd-host
|
|
:family httpd-ip-family
|
|
:filter #'httpd--filter
|
|
:coding 'binary
|
|
:log #'httpd--accept))
|
|
(run-hooks 'httpd-start-hook))
|
|
|
|
;;;###autoload
|
|
(defun httpd-stop ()
|
|
"Stop the web server if it is currently running, otherwise do nothing."
|
|
(interactive)
|
|
(when (httpd-running-p)
|
|
(mapc #'delete-process httpd--clients)
|
|
(delete-process httpd--server)
|
|
(setq httpd--server nil
|
|
httpd--clients nil)
|
|
(httpd-log `(stop ,(httpd-date-string)))
|
|
(run-hooks 'httpd-stop-hook)))
|
|
|
|
;;;###autoload
|
|
(defun httpd-running-p ()
|
|
"Return non-nil if the simple-httpd server is running."
|
|
(process-live-p httpd--server))
|
|
|
|
;;;###autoload
|
|
(defun httpd-serve-directory (&optional directory)
|
|
"Start the web server with given DIRECTORY as `httpd-root'.
|
|
If DIRECTORY is nil use the current `default-directory'."
|
|
(interactive "DServe directory: \n")
|
|
(setq httpd-root (or directory default-directory))
|
|
(httpd-start)
|
|
(message "Started simple-httpd on %s:%d, serving: %s"
|
|
(cl-case httpd-host
|
|
((nil 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\""
|
|
(unless noninteractive
|
|
(error "Only use `httpd-batch-start' in batch mode"))
|
|
(httpd-start)
|
|
(fset #'httpd-log #'pp)
|
|
(while t (sleep-for 60)))
|
|
|
|
;; Utility
|
|
|
|
(defun httpd-date-string (&optional date)
|
|
"Return DATE as HTTP date string (RFC 1123)."
|
|
(format-time-string "%a, %d %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 (obj)
|
|
"Turn OBJ into a string, e.g., symbols, keywords or strings."
|
|
(cond
|
|
((stringp obj) obj)
|
|
((keywordp obj) (substring (symbol-name obj) 1))
|
|
((symbolp obj) (symbol-name obj))
|
|
(t (format "%s" obj))))
|
|
|
|
;; Networking code
|
|
|
|
(defun httpd--connection-close-p (request)
|
|
"Return non-nil if the REQUEST has \"connection: close\"."
|
|
(let ((conn (cadr (assoc "Connection" request))))
|
|
(or (and (stringp conn) (string-equal-ignore-case conn "close"))
|
|
(equal "HTTP/1.0" (caddar request)))))
|
|
|
|
(defun httpd--parse-content-args (request)
|
|
"Parse arguments in content string of REQUEST."
|
|
(when-let* ((content-type (cadr (assoc "Content-Type" request)))
|
|
((string-prefix-p "application/x-www-form-urlencoded"
|
|
content-type)))
|
|
(httpd-parse-args (cadr (assoc "Content" request)))))
|
|
|
|
(defun httpd--handle-request (proc request)
|
|
"Handle REQUEST from client PROC."
|
|
(condition-case err
|
|
(let* ((_ (run-hook-wrapped
|
|
'httpd-filter-functions
|
|
(lambda (fun)
|
|
(setq request (funcall fun request))
|
|
nil)))
|
|
(uri (cadar request))
|
|
(parsed-uri (httpd-parse-uri (concat uri)))
|
|
(uri-path (car parsed-uri))
|
|
(uri-query (nconc (cadr parsed-uri)
|
|
(httpd--parse-content-args request)))
|
|
(servlet (httpd-get-servlet uri-path)))
|
|
(httpd-log `(request
|
|
(date ,(httpd-date-string))
|
|
(address ,(car (process-contact proc)))
|
|
(path ,uri-path)
|
|
(query ,uri-query)
|
|
(servlet ,servlet)
|
|
(headers . ,request)))
|
|
(process-put proc :request-active request)
|
|
(funcall servlet proc uri-path uri-query request))
|
|
(error
|
|
(httpd--error-safe proc 500 err))))
|
|
|
|
(defun httpd--content-string (len)
|
|
"Return request content of length LEN if it is fully transmitted.
|
|
Return nil if transmission is incomplete."
|
|
(if (> len 0)
|
|
(when (>= (buffer-size) len)
|
|
(prog1 (buffer-substring (point-min) (setq len (+ (point-min) len)))
|
|
(delete-region (point-min) len)))
|
|
""))
|
|
|
|
(defun httpd--content-length (request)
|
|
"Return content length of REQUEST."
|
|
(let* ((te (cadr (assoc "Transfer-Encoding" request)))
|
|
(len (cadr (assoc "Content-Length" request))))
|
|
(when (and (or (not te) (string-equal-ignore-case te "identity"))
|
|
(or (not len) (string-match-p "\\`[0-9]+\\'" len)))
|
|
(if len (string-to-number len) 0))))
|
|
|
|
(defun httpd--filter (proc chunk)
|
|
"Process called each time client makes a request.
|
|
PROC is the client process and CHUNK is part of the request as string."
|
|
(with-current-buffer (process-get proc :request-buffer)
|
|
(goto-char (point-max))
|
|
(insert chunk)
|
|
(let ((continue t) (request nil))
|
|
(while continue
|
|
(setq continue nil
|
|
request (process-get proc :request-pending))
|
|
(when (and (not request) (setq request (httpd-parse)))
|
|
(process-put proc :request-pending request)
|
|
(delete-region (point-min) (point)))
|
|
(cond
|
|
(request
|
|
(if-let* ((len (httpd--content-length request)))
|
|
(when-let* ((content (httpd--content-string len)))
|
|
(process-put proc :request-pending nil)
|
|
(httpd--push-request proc (nconc request `(("Content" ,content))))
|
|
(setq continue t))
|
|
(httpd--push-request proc `(("GET" "/error?status=411" "HTTP/1.1")
|
|
("Connection" "close")))))
|
|
((looking-at-p "[^\r\n]*[\r\n]")
|
|
(httpd--push-request proc '(("GET" "/error?status=400" "HTTP/1.1")
|
|
("Connection" "close"))))))))
|
|
(httpd--pop-request proc))
|
|
|
|
(defun httpd--push-request (proc request)
|
|
"Push REQUEST to client PROC queue."
|
|
(cl-callf (lambda (q) (nconc q (list request)))
|
|
(process-get proc :request-queue)))
|
|
|
|
(defun httpd--pop-request (proc)
|
|
"Pop request from client PROC queue and handle it."
|
|
(when-let* (((not (process-get proc :request-active)))
|
|
(request (pop (process-get proc :request-queue))))
|
|
(run-at-time 0 nil #'httpd--handle-request proc request)))
|
|
|
|
(defun httpd--accept (_server proc _message)
|
|
"Runs each time a new client PROC connects to the server."
|
|
(push proc httpd--clients)
|
|
(process-put proc :request-buffer (generate-new-buffer " *httpd-client*" t))
|
|
(set-process-sentinel proc #'httpd--sentinel)
|
|
(httpd-log `(connection ,(car (process-contact proc)))))
|
|
|
|
(defun httpd--sentinel (proc message)
|
|
"Runs when a client PROC closes the connection.
|
|
MESSAGE describes the state change."
|
|
(unless (string-prefix-p "open " message)
|
|
(httpd-log `(close ,(car (process-contact proc))))
|
|
(cl-callf2 delq proc httpd--clients)
|
|
(when-let* ((buffer (process-get proc :request-buffer)))
|
|
(kill-buffer buffer))))
|
|
|
|
;; Logging
|
|
|
|
(defun httpd--log (item)
|
|
"Pretty print ITEM to the log."
|
|
(with-current-buffer (get-buffer-create httpd-log-buffer)
|
|
(setq buffer-read-only t
|
|
truncate-lines t)
|
|
(with-silent-modifications
|
|
(let* ((win (get-buffer-window))
|
|
(follow (and win (= (window-point win) (point-max)))))
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(pp item (current-buffer)))
|
|
(when follow
|
|
(set-window-point win (point-max)))))))
|
|
|
|
(defun httpd-log (item)
|
|
"Pretty print ITEM to the log.
|
|
If `httpd-log-buffer' is nil, ITEM may not be evaluated."
|
|
(declare (compiler-macro
|
|
(lambda (_)
|
|
`(when httpd-log-buffer
|
|
(httpd--log ,item)))))
|
|
(when httpd-log-buffer
|
|
(httpd--log item)))
|
|
|
|
;; Servlets
|
|
|
|
(defvar httpd-current-proc nil
|
|
"The process object currently in use.")
|
|
|
|
(defvar-local httpd--header-sent nil
|
|
"Buffer-local variable indicating if the header has been sent.")
|
|
|
|
(defsubst httpd--resolve-proc (proc)
|
|
"Return the correct process to use.
|
|
Return `httpd-current-proc' if PROC is t."
|
|
(if (eq t proc) httpd-current-proc proc))
|
|
|
|
(defmacro httpd--ensure-buffer (&rest body)
|
|
"Ensure that BODY is executed in a temporary httpd buffer.
|
|
Reuse the current buffer if it is a temporary httpd buffer."
|
|
(declare (indent 0) (debug t))
|
|
(cl-with-gensyms (temp)
|
|
`(let (,temp)
|
|
(with-current-buffer
|
|
(if (eq major-mode 'httpd-buffer)
|
|
(current-buffer)
|
|
(setq ,temp (generate-new-buffer " *httpd-temp*" t)))
|
|
(unwind-protect
|
|
(progn
|
|
(setq major-mode 'httpd-buffer)
|
|
,@body)
|
|
(when (buffer-live-p ,temp)
|
|
(kill-buffer ,temp)))))))
|
|
|
|
(defmacro httpd-with-buffer (proc mime &rest body)
|
|
"Create temporary buffer and serve it to the client.
|
|
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))
|
|
(cl-once-only (proc)
|
|
`(httpd--ensure-buffer
|
|
(let ((standard-output (current-buffer))
|
|
(httpd-current-proc ,proc))
|
|
,@body)
|
|
(unless httpd--header-sent
|
|
(httpd-send-header ,proc ,mime 200)))))
|
|
|
|
(defun httpd-discard-buffer ()
|
|
"Don't respond using current server buffer (`httpd-with-buffer').
|
|
Returns a process for future response.
|
|
|
|
(httpd-servlet slow text/plain ()
|
|
(let ((proc (httpd-discard-buffer)))
|
|
(run-at-time 1 0
|
|
(lambda ()
|
|
(ignore-errors
|
|
(httpd-with-buffer proc \"text/plain\"
|
|
(insert \"Slow response\")))))))"
|
|
(when (eq major-mode 'httpd-buffer) (setq httpd--header-sent t))
|
|
httpd-current-proc)
|
|
|
|
(defmacro httpd-servlet (name mime path-query-request &rest body)
|
|
"Defines a simple httpd servlet.
|
|
|
|
NAME is the servlet name as symbol.
|
|
MIME the mime-type as symbol.
|
|
PATH-QUERY-REQUEST is the argument list.
|
|
BODY is the function body.
|
|
|
|
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*,
|
|
|
|
(httpd-servlet scratch text/plain ()
|
|
(insert-buffer-substring (get-buffer-create \"*scratch*\")))
|
|
|
|
A servlet that says hello,
|
|
|
|
(httpd-servlet hello-world text/plain (path)
|
|
(insert \"hello, \" (file-name-nondirectory path))))"
|
|
(declare (indent defun))
|
|
(cl-with-gensyms (proc-sym rest-sym)
|
|
(let ((fname (intern (concat "httpd/" (symbol-name name)))))
|
|
`(defun ,fname (,proc-sym ,@path-query-request &rest ,rest-sym)
|
|
(httpd-with-buffer ,proc-sym ,(httpd--stringify mime)
|
|
,@body)))))
|
|
|
|
(defun httpd-parse-endpoint (symbol)
|
|
"Parse an endpoint template SYMBOL for use with `httpd-servlet*'."
|
|
(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 return
|
|
(cl-values (intern (string-join path "/")) vars)))
|
|
|
|
(defvar httpd-path nil
|
|
"Dynamic variable bound by `httpd-servlet*'.")
|
|
|
|
(defvar httpd-query nil
|
|
"Dynamic variable bound by `httpd-servlet*'.")
|
|
|
|
(defvar httpd-request nil
|
|
"Dynamic variable bound by `httpd-servlet*'.")
|
|
|
|
(defvar httpd-split-path nil
|
|
"Dynamic variable bound by `httpd-servlet*'.")
|
|
|
|
(defmacro httpd-servlet* (endpoint mime args &rest body)
|
|
"Like `httpd-servlet', but bind variables/arguments to the request.
|
|
|
|
ENDPOINT is the path as symbol.
|
|
MIME the mime-type as symbol.
|
|
ARGS is the argument list.
|
|
BODY is the function body.
|
|
|
|
Trailing components of the ENDPOINT can be bound by prefixing these
|
|
components with a colon, acting like a template.
|
|
|
|
(httpd-servlet* 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).
|
|
|
|
(httpd-servlet* 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 dynamically
|
|
bound variables `httpd-path', `httpd-query', and `httpd-request'."
|
|
(declare (indent defun))
|
|
(cl-with-gensyms (path-lexical query-lexical request-lexical)
|
|
(cl-multiple-value-bind (path vars) (httpd-parse-endpoint endpoint)
|
|
`(httpd-servlet ,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 = `(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 (car arg) arg))
|
|
when has-default collect
|
|
(list (car arg)
|
|
`(let ((value (assoc ,arg-name httpd-query)))
|
|
(if value
|
|
(cadr value)
|
|
,(cadr arg))))
|
|
else collect
|
|
(list arg `(cadr
|
|
(assoc ,arg-name httpd-query)))
|
|
when has-default-p collect
|
|
(list (caddr arg)
|
|
`(not (null (assoc ,arg-name httpd-query)))))
|
|
,@body)))))))
|
|
|
|
(defmacro httpd-file-servlet (name root)
|
|
"Defines a servlet that serves files from ROOT under the route NAME.
|
|
|
|
(httpd-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)))
|
|
`(httpd-servlet ,name nil (uri-path query request)
|
|
(if (= (length uri-path) ,chop)
|
|
(httpd-redirect t ,path-root)
|
|
(httpd-serve-root t ,root (substring uri-path ,chop) request)))))
|
|
|
|
;; Request parsing
|
|
|
|
(defsubst httpd--normalize-header (header)
|
|
"Capitalize the components of HEADER."
|
|
(replace-regexp-in-string "[^-]+" #'capitalize header t))
|
|
|
|
(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."
|
|
(goto-char (point-min))
|
|
(when (looking-at "\\([^ \r\n]+\\) +\\([^ \r\n]+\\) +\\([^\r\n]+\\)\r\n")
|
|
(let ((method (match-string 1))
|
|
(path (decode-coding-string (match-string 2) 'iso-8859-1))
|
|
(version (match-string 3))
|
|
(headers nil))
|
|
(goto-char (match-end 0))
|
|
(while (looking-at "\\([-!#-'*+.0-9A-Z^_`a-z|~]+\\): *\\([^\r\n]+\\)\r\n")
|
|
(goto-char (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")
|
|
(goto-char (match-end 0))
|
|
(cons (list method path version) (nreverse headers))))))
|
|
|
|
(defsubst httpd-unhex (str)
|
|
"Fully decode the URL encoding in STR."
|
|
(decode-coding-string (url-unhex-string str t) 'utf-8))
|
|
|
|
(defsubst httpd-unhex-plus (str)
|
|
"Fully decode URL/form encoding in STR, treating `+' as space."
|
|
(httpd-unhex (string-replace "+" " " str)))
|
|
|
|
(defun httpd-parse-args (str)
|
|
"Parse STR containing URL/form encoded arguments."
|
|
(unless (equal str "")
|
|
(mapcar
|
|
(lambda (s)
|
|
(if-let* ((i (string-search "=" s)))
|
|
(list (httpd-unhex-plus (substring s 0 i))
|
|
(httpd-unhex-plus (substring s (1+ i))))
|
|
(list (httpd-unhex-plus s))))
|
|
(split-string str "&" t))))
|
|
|
|
(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 ((q (string-search "?" uri))
|
|
(h (string-search "#" uri)))
|
|
(when (and q h (> q h))
|
|
(setq q nil))
|
|
(list (httpd-unhex (substring uri 0 (or q h)))
|
|
(and q (httpd-parse-args (substring uri (1+ q) h)))
|
|
(and h (httpd-unhex (substring uri (1+ h)))))))
|
|
|
|
(defconst httpd--html-entities
|
|
'((?& . "&")
|
|
(?' . "'")
|
|
(?\" . """)
|
|
(?< . "<")
|
|
(?> . ">"))
|
|
"Alist of HTML entities escaped by `httpd-escape-html-buffer'.")
|
|
|
|
(defun httpd-escape-html-buffer ()
|
|
"Escape current buffer contents to be safe for inserting into HTML."
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "[<>&'\"]" nil t)
|
|
(replace-match
|
|
(alist-get (char-after (match-beginning 0)) httpd--html-entities))))
|
|
|
|
(defun httpd-escape-html (str)
|
|
"Escape STR so that it's safe to insert into an HTML document."
|
|
(replace-regexp-in-string
|
|
"[<>&'\"]"
|
|
(lambda (c) (alist-get (aref c 0) httpd--html-entities))
|
|
str))
|
|
|
|
;; 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 (memq system-type '(windows-nt ms-dos)) "[/\\]" "/")))
|
|
(concat "./" (string-join (delete ".." (split-string path sep t)) "/"))))
|
|
|
|
(defun httpd-gen-path (path &optional root)
|
|
"Generate secure path in ROOT from request PATH."
|
|
(let ((clean (expand-file-name (httpd-clean-path path) root)))
|
|
(if (file-directory-p clean)
|
|
(let* ((dir (file-name-as-directory clean))
|
|
(indexes (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."
|
|
(or
|
|
(and httpd-servlets
|
|
(cl-find-if
|
|
#'fboundp
|
|
(cl-maplist
|
|
(lambda (x)
|
|
(intern-soft (string-join (cons "httpd" (reverse x)) "/")))
|
|
(nreverse (cdr (split-string (directory-file-name uri-path) "/"))))))
|
|
'httpd/))
|
|
|
|
(defun httpd-serve-root (proc root uri-path &optional request)
|
|
"Securely serve a file from ROOT.
|
|
PROC is the client process, URI-PATH the request path and REQUEST the
|
|
request header as alist."
|
|
(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.
|
|
PROC is the client process, URI-PATH the request path, QUERY the query
|
|
arguments and REQUEST the request header as alist."
|
|
(cond
|
|
((equal uri-path "/error")
|
|
(let ((status (string-to-number (or (cadr (assoc "status" query)) ""))))
|
|
(unless (and (assq status httpd-status-codes) (>= status 400))
|
|
(setq status 400))
|
|
(httpd-error proc status)))
|
|
((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 extension EXT."
|
|
(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 followed by the current buffer.
|
|
MIME is the mime type and STATUS the HTTP status code. 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\")"
|
|
(when httpd--header-sent
|
|
(error "Header already sent"))
|
|
(setq httpd--header-sent t)
|
|
(let* ((proc (httpd--resolve-proc proc))
|
|
(request (or (process-get proc :request-active)
|
|
(error "No active request")))
|
|
(status-str (alist-get status httpd-status-codes))
|
|
(mime-str (httpd--stringify mime))
|
|
(mime-str (if (and (string-prefix-p "text/" mime-str)
|
|
(not (string-search "charset=" mime-str)))
|
|
(concat mime-str "; charset=utf-8")
|
|
mime-str))
|
|
(close (httpd--connection-close-p request))
|
|
(headers `(("Date" . ,(httpd-date-string))
|
|
("Content-Type" . ,mime-str)
|
|
("Content-Length" . ,(httpd--buffer-size))
|
|
("Connection" . ,(if close "close" "keep-alive"))
|
|
,@(and httpd-server-name `(("Server" . ,httpd-server-name)))))
|
|
(header-list `(,(format "%s %d %s\r\n" (caddar request) status status-str)
|
|
,@(cl-loop for (header . value) in headers collect
|
|
(format "%s: %s\r\n" header value))
|
|
,@(cl-loop for (header value) on header-keys by #'cddr collect
|
|
(format "%s: %s\r\n" (httpd--stringify header) value))
|
|
"\r\n")))
|
|
(process-put proc :request-active nil)
|
|
(process-send-string proc (apply #'concat header-list))
|
|
(unless (or (= (point-min) (point-max)) (equal "HEAD" (caar request)))
|
|
(process-send-region proc (point-min) (point-max)))
|
|
(if close
|
|
(delete-process proc)
|
|
(httpd--pop-request proc))))
|
|
|
|
(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 `(redirect ,path))
|
|
(httpd--ensure-buffer
|
|
(httpd-send-header proc "text/plain" (or code 301) :Location path)))
|
|
|
|
(defun httpd-send-file (proc path &optional req)
|
|
"Serve file at PATH to the given client PROC.
|
|
REQ is the request. If PROC is t use the `httpd-current-proc' as the
|
|
process."
|
|
(httpd--ensure-buffer
|
|
(let ((etag (httpd-etag path)))
|
|
(if (not (equal (cadr (assoc "If-None-Match" req)) etag))
|
|
(let ((mime (httpd-get-mime (file-name-extension path)))
|
|
(mtime (httpd-date-string
|
|
(file-attribute-modification-time
|
|
(file-attributes path)))))
|
|
(httpd-log `(file ,path))
|
|
(set-buffer-multibyte nil)
|
|
(insert-file-contents-literally path)
|
|
(httpd-send-header proc mime 200
|
|
:ETag etag :Last-Modified mtime))
|
|
(httpd-log `(file ,path not-modified))
|
|
(httpd-send-header proc "text/plain" 304)))))
|
|
|
|
(defun httpd-send-directory (proc path uri-path)
|
|
"Serve a file listing to the client.
|
|
PROC is the client process, PATH the directory PATH, URI-PATH the
|
|
request path and REQUEST the request header as alist. If PROC is t use
|
|
the `httpd-current-proc' as the process."
|
|
(if (string-suffix-p "/" uri-path)
|
|
(let ((title (concat "Directory listing for "
|
|
(httpd-escape-html uri-path))))
|
|
(httpd--ensure-buffer
|
|
(httpd-log `(directory ,path))
|
|
(insert "<!DOCTYPE html>\n"
|
|
"<html>\n<head><title>" title "</title></head>\n"
|
|
"<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 (httpd-escape-html 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" 200)))
|
|
(httpd-redirect proc (concat uri-path "/"))))
|
|
|
|
(defun httpd--buffer-size ()
|
|
"Get size of current buffer in bytes."
|
|
(let ((orig enable-multibyte-characters))
|
|
(set-buffer-multibyte nil)
|
|
(prog1 (buffer-size)
|
|
(when orig (set-buffer-multibyte orig)))))
|
|
|
|
(defun httpd-error (proc status &optional info)
|
|
"Send an error page appropriate for STATUS to the client.
|
|
The INFO object is optionally inserted into page. If PROC is t use the
|
|
`httpd-current-proc' as the process."
|
|
(httpd-log `(error ,status ,info))
|
|
(httpd--ensure-buffer
|
|
(let ((contents
|
|
(if (or info httpd-show-backtrace-when-error)
|
|
(with-temp-buffer
|
|
(let ((standard-output (current-buffer)))
|
|
(when info
|
|
(insert "error: ")
|
|
(princ info)
|
|
(insert ?\n))
|
|
(when httpd-show-backtrace-when-error
|
|
(insert "backtrace:\n")
|
|
(backtrace)
|
|
(insert ?\n))
|
|
(httpd-escape-html-buffer)
|
|
(buffer-string)))
|
|
"")))
|
|
(insert (format
|
|
(or (alist-get status httpd-html)
|
|
(alist-get t httpd-html))
|
|
contents status
|
|
(alist-get status httpd-status-codes)) ?\n))
|
|
(httpd-send-header proc "text/html" status)))
|
|
|
|
(defun httpd--error-safe (&rest args)
|
|
"Call `httpd-error' with ARGS and log failures."
|
|
(condition-case err
|
|
(apply #'httpd-error args)
|
|
(error (httpd-log `(hard-error ,err)))))
|
|
|
|
;; Old names. Not deprecated to avoid churn.
|
|
(defalias 'defservlet #'httpd-servlet)
|
|
(defalias 'defservlet* #'httpd-servlet*)
|
|
(defalias 'httpd-def-file-servlet #'httpd-file-servlet)
|
|
(defalias 'with-httpd-buffer #'httpd-with-buffer)
|
|
(defalias 'httpd-resolve-proc #'httpd--resolve-proc)
|
|
|
|
(provide 'simple-httpd)
|
|
;;; simple-httpd.el ends here
|