From: Andreas Gerler Date: Sun, 26 Nov 2023 15:29:02 +0000 (+0100) Subject: update simple-httpd X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=59768ea17888bca97e424cfbe76bcb7e9f6f7b88;p=emacsconfig.git update simple-httpd Signed-off-by: Andreas Gerler --- diff --git a/elpa/simple-httpd-20191103.1446/simple-httpd-autoloads.el b/elpa/simple-httpd-20191103.1446/simple-httpd-autoloads.el deleted file mode 100644 index a042623f..00000000 --- a/elpa/simple-httpd-20191103.1446/simple-httpd-autoloads.el +++ /dev/null @@ -1,44 +0,0 @@ -;;; simple-httpd-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "simple-httpd" "simple-httpd.el" (0 0 0 0)) -;;; Generated autoloads from simple-httpd.el - -(autoload 'httpd-start "simple-httpd" "\ -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. - -\(fn)" t nil) - -(autoload 'httpd-stop "simple-httpd" "\ -Stop the web server if it is currently running, otherwise do nothing. - -\(fn)" t nil) - -(autoload 'httpd-running-p "simple-httpd" "\ -Return non-nil if the simple-httpd server is running. - -\(fn)" nil nil) - -(autoload 'httpd-serve-directory "simple-httpd" "\ -Start the web server with given `directory' as `httpd-root'. - -\(fn DIRECTORY)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "simple-httpd" '("httpd" "defservlet" "with-httpd-buffer"))) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; simple-httpd-autoloads.el ends here diff --git a/elpa/simple-httpd-20191103.1446/simple-httpd-pkg.el b/elpa/simple-httpd-20191103.1446/simple-httpd-pkg.el deleted file mode 100644 index 86794ddd..00000000 --- a/elpa/simple-httpd-20191103.1446/simple-httpd-pkg.el +++ /dev/null @@ -1,2 +0,0 @@ -;;; -*- no-byte-compile: t -*- -(define-package "simple-httpd" "20191103.1446" "pure elisp HTTP server" '((cl-lib "0.3")) :commit "22ce66ea43e0eadb9ec1d691a35d9695fc29cee6" :authors '(("Christopher Wellons" . "wellons@nullprogram.com")) :maintainer '("Christopher Wellons" . "wellons@nullprogram.com") :url "https://github.com/skeeto/emacs-http-server") diff --git a/elpa/simple-httpd-20191103.1446/simple-httpd.el b/elpa/simple-httpd-20191103.1446/simple-httpd.el deleted file mode 100644 index 9801b970..00000000 --- a/elpa/simple-httpd-20191103.1446/simple-httpd.el +++ /dev/null @@ -1,903 +0,0 @@ -;;; simple-httpd.el --- pure elisp HTTP server - -;; This is free and unencumbered software released into the public domain. - -;; Author: Christopher Wellons -;; URL: https://github.com/skeeto/emacs-http-server -;; Package-Version: 20191103.1446 -;; 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 . " - -403 Forbidden - -

Forbidden

-

The requested URL is forbidden.

-
%s
-") - (404 . " - -404 Not Found - -

Not Found

-

The requested URL was not found on this server.

-
%s
-") - (500 . " - -500 Internal Error - -

500 Internal Error

-

Internal error when handling this request.

-
%s
-")) - "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) - (?< "<") - (?> ">") - (?& "&"))))) - -(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 "\n") - (insert "\n" title "\n") - (insert "\n

" title "

\n
\n
    ") - (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 "
  • %s%s
    • \n" - l tail f tail))))) - (insert "
\n
\n\n") - (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 diff --git a/elpa/simple-httpd-20230619.642/simple-httpd-autoloads.el b/elpa/simple-httpd-20230619.642/simple-httpd-autoloads.el new file mode 100644 index 00000000..e0d7a5cb --- /dev/null +++ b/elpa/simple-httpd-20230619.642/simple-httpd-autoloads.el @@ -0,0 +1,42 @@ +;;; simple-httpd-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "simple-httpd" "simple-httpd.el" (0 0 0 0)) +;;; Generated autoloads from simple-httpd.el + +(autoload 'httpd-start "simple-httpd" "\ +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." t nil) + +(autoload 'httpd-stop "simple-httpd" "\ +Stop the web server if it is currently running, otherwise do nothing." t nil) + +(autoload 'httpd-running-p "simple-httpd" "\ +Return non-nil if the simple-httpd server is running." nil nil) + +(autoload 'httpd-serve-directory "simple-httpd" "\ +Start the web server with given `directory' as `httpd-root'. + +\(fn DIRECTORY)" t nil) + +(register-definition-prefixes "simple-httpd" '("defservlet" "httpd" "with-httpd-buffer")) + +;;;*** + +;;;### (autoloads nil nil ("simple-httpd-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; simple-httpd-autoloads.el ends here diff --git a/elpa/simple-httpd-20230619.642/simple-httpd-pkg.el b/elpa/simple-httpd-20230619.642/simple-httpd-pkg.el new file mode 100644 index 00000000..6fc262d7 --- /dev/null +++ b/elpa/simple-httpd-20230619.642/simple-httpd-pkg.el @@ -0,0 +1,12 @@ +(define-package "simple-httpd" "20230619.642" "pure elisp HTTP server" + '((cl-lib "0.3")) + :commit "6260232da8b53c4e214bc5e427ec00c3ebdd9869" :authors + '(("Christopher Wellons" . "wellons@nullprogram.com")) + :maintainers + '(("Christopher Wellons" . "wellons@nullprogram.com")) + :maintainer + '("Christopher Wellons" . "wellons@nullprogram.com") + :url "https://github.com/skeeto/emacs-http-server") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/simple-httpd-20230619.642/simple-httpd.el b/elpa/simple-httpd-20230619.642/simple-httpd.el new file mode 100644 index 00000000..a1da44e2 --- /dev/null +++ b/elpa/simple-httpd-20230619.642/simple-httpd.el @@ -0,0 +1,903 @@ +;;; simple-httpd.el --- pure elisp HTTP server + +;; This is free and unencumbered software released into the public domain. + +;; Author: Christopher Wellons +;; URL: https://github.com/skeeto/emacs-http-server +;; 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") + ("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 + '((403 . " + +403 Forbidden + +

Forbidden

+

The requested URL is forbidden.

+
%s
+") + (404 . " + +404 Not Found + +

Not Found

+

The requested URL was not found on this server.

+
%s
+") + (500 . " + +500 Internal Error + +

500 Internal Error

+

Internal error when handling this request.

+
%s
+")) + "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) + (?< "<") + (?> ">") + (?& "&"))))) + +(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 "\n") + (insert "\n" title "\n") + (insert "\n

" title "

\n
\n
    ") + (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 "
  • %s%s
    • \n" + l tail f tail))))) + (insert "
\n
\n\n") + (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