750 lines
34 KiB
EmacsLisp
750 lines
34 KiB
EmacsLisp
;;; web-server.el --- Emacs Web Server -*- lexical-binding: t -*-
|
||
|
||
;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
|
||
|
||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||
;; Maintainer: Eric Schulte <schulte.eric@gmail.com>
|
||
;; Version: 0.1.2
|
||
;; Package-Requires: ((emacs "24.3"))
|
||
;; Keywords: http, server, network
|
||
;; URL: https://github.com/eschulte/emacs-web-server
|
||
|
||
;; This software is free software: you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This software is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; A web server in Emacs running handlers written in Emacs Lisp.
|
||
;;
|
||
;; Full support for GET and POST requests including URL-encoded
|
||
;; parameters and multipart/form data. Supports web sockets.
|
||
;;
|
||
;; See the examples/ directory for examples demonstrating the usage of
|
||
;; the Emacs Web Server. The following launches a simple "hello
|
||
;; world" server.
|
||
;;
|
||
;; (ws-start
|
||
;; '(((lambda (_) t) . ; match every request
|
||
;; (lambda (request) ; reply with "hello world"
|
||
;; (with-slots (process) request
|
||
;; (ws-response-header process 200 '("Content-type" . "text/plain"))
|
||
;; (process-send-string process "hello world")))))
|
||
;; 9000)
|
||
|
||
;;; Code:
|
||
(require 'web-server-status-codes)
|
||
(require 'mail-parse) ; to parse multipart data in headers
|
||
(require 'mm-encode) ; to look-up mime types for files
|
||
(require 'url-util) ; to decode url-encoded params
|
||
(require 'eieio)
|
||
(eval-when-compile (require 'cl))
|
||
(require 'cl-lib)
|
||
|
||
(defclass ws-server ()
|
||
((handlers :initarg :handlers :accessor ws-handlers :initform nil)
|
||
(process :initarg :process :accessor ws-process :initform nil)
|
||
(port :initarg :port :accessor ws-port :initform nil)
|
||
(requests :initarg :requests :accessor ws-requests :initform nil)))
|
||
|
||
(defclass ws-request ()
|
||
((process :initarg :process :accessor ws-process :initform nil)
|
||
(pending :initarg :pending :accessor ws-pending :initform "")
|
||
(context :initarg :context :accessor ws-context :initform nil)
|
||
(boundary :initarg :boundary :accessor ws-boundary :initform nil)
|
||
(index :initarg :index :accessor ws-index :initform 0)
|
||
(active :initarg :active :accessor ws-active :initform nil)
|
||
(headers :initarg :headers :accessor ws-headers :initform (list nil))
|
||
(body :initarg :body :accessor ws-body :initform "")))
|
||
|
||
(defvar ws-servers nil
|
||
"List holding all web servers.")
|
||
|
||
(defvar ws-log-time-format "%Y.%m.%d.%H.%M.%S.%N"
|
||
"Logging time format passed to `format-time-string'.")
|
||
|
||
(defvar ws-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
|
||
"This GUID is defined in RFC6455.")
|
||
|
||
;;;###autoload
|
||
(defun ws-start (handlers port &optional log-buffer &rest network-args)
|
||
"Start a server using HANDLERS and return the server object.
|
||
|
||
HANDLERS may be a single function (which is then called on every
|
||
request) or a list of conses of the form (MATCHER . FUNCTION),
|
||
where the FUNCTION associated with the first successful MATCHER
|
||
is called. Handler functions are called with two arguments, the
|
||
process and the request object.
|
||
|
||
A MATCHER may be either a function (in which case it is called on
|
||
the request object) or a cons cell of the form (KEYWORD . STRING)
|
||
in which case STRING is matched against the value of the header
|
||
specified by KEYWORD.
|
||
|
||
Any supplied NETWORK-ARGS are assumed to be keyword arguments for
|
||
`make-network-process' to which they are passed directly.
|
||
|
||
For example, the following starts a simple hello-world server on
|
||
port 8080.
|
||
|
||
(ws-start
|
||
(lambda (request)
|
||
(with-slots (process headers) request
|
||
(process-send-string process
|
||
\"HTTP/1.1 200 OK\\r\\nContent-Type: text/plain\\r\\n\\r\\nhello world\")))
|
||
8080)
|
||
|
||
Equivalently, the following starts an identical server using a
|
||
function MATCH and the `ws-response-header' convenience
|
||
function.
|
||
|
||
(ws-start
|
||
'(((lambda (_) t) .
|
||
(lambda (proc request)
|
||
(ws-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
|
||
(process-send-string proc \"hello world\")
|
||
t)))
|
||
8080)
|
||
|
||
"
|
||
(let ((server (make-instance 'ws-server :handlers handlers :port port))
|
||
(log (when log-buffer (get-buffer-create log-buffer))))
|
||
(setf (ws-process server)
|
||
(apply
|
||
#'make-network-process
|
||
:name "ws-server"
|
||
:service (ws-port server)
|
||
:filter 'ws-filter
|
||
:server t
|
||
:nowait (< emacs-major-version 26)
|
||
:family 'ipv4
|
||
:coding 'no-conversion
|
||
:plist (append (list :server server)
|
||
(when log (list :log-buffer log)))
|
||
:log (when log
|
||
(lambda (proc request message)
|
||
(let ((c (process-contact request))
|
||
(buf (plist-get (process-plist proc) :log-buffer)))
|
||
(with-current-buffer buf
|
||
(goto-char (point-max))
|
||
(insert (format "%s\t%s\t%s\t%s"
|
||
(format-time-string ws-log-time-format)
|
||
(first c) (second c) message))))))
|
||
network-args))
|
||
(push server ws-servers)
|
||
server))
|
||
|
||
(defun ws-stop (server)
|
||
"Stop SERVER."
|
||
(setq ws-servers (remove server ws-servers))
|
||
(mapc #'delete-process (append (mapcar #'ws-process (ws-requests server))
|
||
(list (ws-process server)))))
|
||
|
||
(defun ws-stop-all ()
|
||
"Stop all servers in `ws-servers'."
|
||
(interactive)
|
||
(mapc #'ws-stop ws-servers))
|
||
|
||
(defvar ws-http-common-methods '(GET HEAD POST PUT DELETE TRACE)
|
||
"HTTP methods from http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html.")
|
||
|
||
(defvar ws-http-method-rx
|
||
(format "^\\(%s\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$"
|
||
(mapconcat #'symbol-name ws-http-common-methods "\\|")))
|
||
|
||
(defun ws-parse-query-string (string)
|
||
"Thin wrapper around `url-parse-query-string'."
|
||
(mapcar (lambda (pair) (cons (first pair) (second pair)))
|
||
(url-parse-query-string string nil 'allow-newlines)))
|
||
|
||
(defun ws-parse (proc string)
|
||
"Parse HTTP headers in STRING reporting errors to PROC."
|
||
(cl-flet ((to-keyword (s) (intern (concat ":" (upcase s)))))
|
||
(cond
|
||
;; Method
|
||
((string-match ws-http-method-rx string)
|
||
(let ((method (to-keyword (match-string 1 string)))
|
||
(url (match-string 2 string)))
|
||
(if (string-match "?" url)
|
||
(cons (cons method (substring url 0 (match-beginning 0)))
|
||
(ws-parse-query-string
|
||
(url-unhex-string (substring url (match-end 0)))))
|
||
(list (cons method url)))))
|
||
;; Authorization
|
||
((string-match "^AUTHORIZATION: \\([^[:space:]]+\\) \\(.*\\)$" string)
|
||
(let ((protocol (to-keyword (match-string 1 string)))
|
||
(credentials (match-string 2 string)))
|
||
(list (cons :AUTHORIZATION
|
||
(cons protocol
|
||
(case protocol
|
||
(:BASIC
|
||
(let ((cred (base64-decode-string credentials)))
|
||
(if (string-match ":" cred)
|
||
(cons (substring cred 0 (match-beginning 0))
|
||
(substring cred (match-end 0)))
|
||
(ws-error proc "bad credentials: %S" cred))))
|
||
(t (ws-error proc "un-support protocol: %s"
|
||
protocol))))))))
|
||
;; All other headers
|
||
((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
|
||
(list (cons (to-keyword (match-string 1 string))
|
||
(match-string 2 string))))
|
||
(:otherwise (ws-error proc "bad header: %S" string) nil))))
|
||
|
||
(defun ws-trim (string)
|
||
(while (and (> (length string) 0)
|
||
(or (and (string-match "[\r\n]" (substring string -1))
|
||
(setq string (substring string 0 -1)))
|
||
(and (string-match "[\r\n]" (substring string 0 1))
|
||
(setq string (substring string 1))))))
|
||
string)
|
||
|
||
(defun ws-parse-multipart/form (proc string)
|
||
;; ignore empty and non-content blocks
|
||
(when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
|
||
(let ((dp (cdr (mail-header-parse-content-disposition
|
||
(match-string 1 string))))
|
||
(last-index (match-end 0))
|
||
index)
|
||
;; every line up until the double \r\n is a header
|
||
(while (and (setq index (string-match "\r\n" string last-index))
|
||
(not (= index last-index)))
|
||
(setcdr (last dp) (ws-parse proc (substring string last-index index)))
|
||
(setq last-index (+ 2 index)))
|
||
;; after double \r\n is all content
|
||
(cons (cdr (assoc 'name dp))
|
||
(cons (cons 'content (substring string (+ 2 last-index)))
|
||
dp)))))
|
||
|
||
(defun ws-filter (proc string)
|
||
(with-slots (handlers requests) (plist-get (process-plist proc) :server)
|
||
(unless (cl-find-if (lambda (c) (equal proc (ws-process c))) requests)
|
||
(push (make-instance 'ws-request :process proc) requests))
|
||
(let ((request (cl-find-if (lambda (c) (equal proc (ws-process c))) requests)))
|
||
(with-slots (pending) request (setq pending (concat pending string)))
|
||
(unless (ws-active request) ; don't re-start if request is being parsed
|
||
(setf (ws-active request) t)
|
||
(when (not (eq (catch 'close-connection
|
||
(if (ws-parse-request request)
|
||
(ws-call-handler request handlers)
|
||
:keep-alive))
|
||
:keep-alive))
|
||
;; Properly shut down processes requiring an ending (e.g., chunked)
|
||
(let ((ender (plist-get (process-plist proc) :ender)))
|
||
(when ender (process-send-string proc ender)))
|
||
(setq requests (cl-remove-if (lambda (r) (eql proc (ws-process r))) requests))
|
||
(delete-process proc))))))
|
||
|
||
(defun ws-parse-request (request)
|
||
"Parse request STRING from REQUEST with process PROC.
|
||
Return non-nil only when parsing is complete."
|
||
(catch 'finished-parsing-headers
|
||
(with-slots (process pending context boundary headers body index) request
|
||
(let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
|
||
;; Track progress through string, always work with the
|
||
;; section of string between INDEX and NEXT-INDEX.
|
||
next-index
|
||
body-stored)
|
||
;; parse headers and append to request
|
||
(while (setq next-index (string-match delimiter pending index))
|
||
(let ((tmp (+ next-index (length delimiter))))
|
||
(if (= index next-index) ; double \r\n ends current run of headers
|
||
(progn
|
||
;; Store the body
|
||
(unless
|
||
;; Multipart form data has multiple passes - store on
|
||
;; first pass only.
|
||
body-stored
|
||
(let ((after-headers (substring pending index)))
|
||
(when (string-prefix-p "\r\n" after-headers)
|
||
(setq body
|
||
;; Trim off the additional CRLF
|
||
(substring after-headers 2))))
|
||
(setq body-stored t))
|
||
(case context
|
||
;; Parse URL data.
|
||
;; http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4
|
||
(application/x-www-form-urlencoded
|
||
(mapc (lambda (pair) (setcdr (last headers) (list pair)))
|
||
(ws-parse-query-string
|
||
(replace-regexp-in-string
|
||
"\\+" " "
|
||
(ws-trim (substring pending index)))))
|
||
(throw 'finished-parsing-headers t))
|
||
;; Set custom delimiter for multipart form data.
|
||
(multipart/form-data
|
||
(setq delimiter (concat "\r\n--" boundary)))
|
||
;; No special context so we're done.
|
||
(t (throw 'finished-parsing-headers t))))
|
||
(if (eql context 'multipart/form-data)
|
||
(progn
|
||
(setcdr (last headers)
|
||
(list (ws-parse-multipart/form process
|
||
(substring pending index next-index))))
|
||
;; Boundary suffixed by "--" indicates end of the headers.
|
||
(when (and (> (length pending) (+ tmp 2))
|
||
(string= (substring pending tmp (+ tmp 2)) "--"))
|
||
(throw 'finished-parsing-headers t)))
|
||
;; Standard header parsing.
|
||
(let ((header (ws-parse process (substring pending
|
||
index next-index))))
|
||
;; Content-Type indicates that the next double \r\n
|
||
;; will be followed by a special type of content which
|
||
;; will require special parsing. Thus we will note
|
||
;; the type in the CONTEXT variable for parsing
|
||
;; dispatch above.
|
||
(when (and (caar header) (eql (caar header) :CONTENT-TYPE))
|
||
(cl-destructuring-bind (type &rest data)
|
||
(mail-header-parse-content-type (cdar header))
|
||
(setq boundary (cdr (assoc 'boundary data)))
|
||
(setq context (intern (downcase type)))))
|
||
;; All other headers are collected directly.
|
||
(setcdr (last headers) header))))
|
||
(setq index tmp)))))
|
||
(setf (ws-active request) nil)
|
||
nil))
|
||
|
||
(defun ws-call-handler (request handlers)
|
||
(catch 'matched-handler
|
||
(when (functionp handlers)
|
||
(throw 'matched-handler
|
||
(condition-case e (funcall handlers request)
|
||
(error (ws-error (ws-process request) "Caught Error: %S" e)))))
|
||
(mapc (lambda (handler)
|
||
(let ((match (car handler))
|
||
(function (cdr handler)))
|
||
(when (or (and (consp match)
|
||
(assoc (car match) (ws-headers request))
|
||
(string-match (cdr match)
|
||
(cdr (assoc (car match)
|
||
(ws-headers request)))))
|
||
(and (functionp match) (funcall match request)))
|
||
(throw 'matched-handler
|
||
(condition-case e (funcall function request)
|
||
(error (ws-error (ws-process request)
|
||
"Caught Error: %S" e)))))))
|
||
handlers)
|
||
(ws-error (ws-process request) "no handler matched request: %S"
|
||
(ws-headers request))))
|
||
|
||
(defun ws-error (proc msg &rest args)
|
||
(let ((buf (plist-get (process-plist proc) :log-buffer))
|
||
(c (process-contact proc)))
|
||
(when buf
|
||
(with-current-buffer buf
|
||
(goto-char (point-max))
|
||
(insert (format "%s\t%s\t%s\tWS-ERROR: %s"
|
||
(format-time-string ws-log-time-format)
|
||
(first c) (second c)
|
||
(apply #'format msg args)))))
|
||
(apply #'ws-send-500 proc msg args)))
|
||
|
||
|
||
;;; Web Socket
|
||
;; Implement to conform to http://tools.ietf.org/html/rfc6455.
|
||
|
||
;; The `ws-message' object is used to hold state across multiple calls
|
||
;; of the process filter on the websocket network process. The fields
|
||
;; play the following roles.
|
||
;; process ------ holds the process itself, used for communication
|
||
;; pending ------ holds text received from the client but not yet parsed
|
||
;; active ------- indicates that parsing is active to avoid re-entry
|
||
;; of the `ws-web-socket-parse-messages' function
|
||
;; new ---------- indicates that new text was received during parsing
|
||
;; and causes `ws-web-socket-parse-messages' to be
|
||
;; called again after it terminates
|
||
;; data --------- holds the data of parsed messages
|
||
;; handler ------ holds the user-supplied function used called on the
|
||
;; data of parsed messages
|
||
(defclass ws-message () ; web socket message object
|
||
((process :initarg :process :accessor ws-process :initform "")
|
||
(pending :initarg :pending :accessor ws-pending :initform "")
|
||
(active :initarg :active :accessor ws-active :initform nil)
|
||
(new :initarg :new :accessor ws-new :initform nil)
|
||
(data :initarg :data :accessor ws-data :initform "")
|
||
(handler :initarg :handler :accessor ws-handler :initform "")))
|
||
|
||
(defun ws-web-socket-connect (request handler)
|
||
"Establish a web socket connection with request.
|
||
If the connection is successful this function will throw
|
||
`:keep-alive' to `close-connection' skipping any remaining code
|
||
in the request handler. If no web-socket connection is
|
||
established (e.g., because REQUEST is not attempting to establish
|
||
a connection) then no actions are taken and nil is returned.
|
||
|
||
Second argument HANDLER should be a function of one argument
|
||
which will be called on all complete messages as they are
|
||
received and parsed from the network."
|
||
(with-slots (process headers) request
|
||
(when (assoc :SEC-WEBSOCKET-KEY headers)
|
||
;; Accept the connection
|
||
(ws-response-header process 101
|
||
(cons "Upgrade" "websocket")
|
||
(cons "Connection" "upgrade")
|
||
(cons "Sec-WebSocket-Accept"
|
||
(ws-web-socket-handshake
|
||
(cdr (assoc :SEC-WEBSOCKET-KEY headers)))))
|
||
;; Setup the process filter
|
||
(set-process-coding-system process 'binary)
|
||
(set-process-plist
|
||
process (list :message (make-instance 'ws-message
|
||
:handler handler :process process)))
|
||
(set-process-filter process 'ws-web-socket-filter)
|
||
process)))
|
||
|
||
(defun ws-web-socket-filter (process string)
|
||
(let ((message (plist-get (process-plist process) :message)))
|
||
(if (ws-active message) ; don't re-start if message is being parsed
|
||
(setf (ws-new message) string)
|
||
(setf (ws-pending message) (concat (ws-pending message) string))
|
||
(setf (ws-active message) t)
|
||
(ws-web-socket-parse-messages message))
|
||
(setf (ws-active message) nil)))
|
||
|
||
(defun ws-web-socket-mask (masking-key data)
|
||
(let ((masking-data (apply #'concat (make-list (+ 1 (/ (length data) 4))
|
||
masking-key))))
|
||
(apply #'string (cl-mapcar #'logxor masking-data data))))
|
||
|
||
;; Binary framing protocol
|
||
;; from http://tools.ietf.org/html/rfc6455#section-5.2
|
||
;;
|
||
;; 0 1 2 3
|
||
;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
|
||
;; +-+-+-+-+-------+-+-------------+-------------------------------+
|
||
;; |F|R|R|R| opcode|M| Payload len | Extended payload length |
|
||
;; |I|S|S|S| (4) |A| (7) | (16/64) |
|
||
;; |N|V|V|V| |S| | (if payload len==126/127) |
|
||
;; | |1|2|3| |K| | |
|
||
;; +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
|
||
;; | Extended payload length continued, if payload len == 127 |
|
||
;; + - - - - - - - - - - - - - - - +-------------------------------+
|
||
;; | |Masking-key, if MASK set to 1 |
|
||
;; +-------------------------------+-------------------------------+
|
||
;; | Masking-key (continued) | Payload Data |
|
||
;; +-------------------------------- - - - - - - - - - - - - - - - +
|
||
;; : Payload Data continued ... :
|
||
;; + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
|
||
;; | Payload Data continued ... |
|
||
;; +---------------------------------------------------------------+
|
||
;;
|
||
(defun ws-web-socket-parse-messages (message)
|
||
"Web socket filter to pass whole frames to the client.
|
||
See RFC6455."
|
||
(with-slots (process active pending data handler new) message
|
||
(let ((index 0))
|
||
(cl-labels ((int-to-bits (int size)
|
||
(let ((result (make-bool-vector size nil)))
|
||
(mapc (lambda (place)
|
||
(let ((val (expt 2 place)))
|
||
(when (>= int val)
|
||
(setq int (- int val))
|
||
(aset result place t))))
|
||
(reverse (number-sequence 0 (- size 1))))
|
||
(reverse (append result nil))))
|
||
(bits-to-int (bits)
|
||
(let ((place 0))
|
||
(apply #'+
|
||
(mapcar (lambda (bit)
|
||
(prog1 (if bit (expt 2 place) 0) (incf place)))
|
||
(reverse bits)))))
|
||
(bits (length)
|
||
(apply #'append
|
||
(mapcar (lambda (int) (int-to-bits int 8))
|
||
(cl-subseq
|
||
pending index (incf index length))))))
|
||
(let (fin rsvs opcode mask pl mask-key)
|
||
;; Parse fin bit, rsvs bits and opcode
|
||
(let ((byte (bits 1)))
|
||
(setq fin (car byte)
|
||
rsvs (cl-subseq byte 1 4)
|
||
opcode
|
||
(let ((it (bits-to-int (cl-subseq byte 4))))
|
||
(case it
|
||
(0 :CONTINUATION)
|
||
(1 :TEXT)
|
||
(2 :BINARY)
|
||
((3 4 5 6 7) :NON-CONTROL)
|
||
(8 :CLOSE)
|
||
(9 :PING)
|
||
(10 :PONG)
|
||
((11 12 13 14 15) :CONTROL)
|
||
;; If an unknown opcode is received, the receiving
|
||
;; endpoint MUST _Fail the WebSocket Connection_.
|
||
(t (ws-error process
|
||
"Web Socket Fail: bad opcode %d" it))))))
|
||
(unless (cl-every #'null rsvs)
|
||
;; MUST be 0 unless an extension is negotiated that defines
|
||
;; meanings for non-zero values.
|
||
(ws-error process "Web Socket Fail: non-zero RSV 1 2 or 3"))
|
||
;; Parse mask and payload length
|
||
(let ((byte (bits 1)))
|
||
(setq mask (car byte)
|
||
pl (bits-to-int (cl-subseq byte 1))))
|
||
(unless (eq mask t)
|
||
;; All frames sent from client to server have this bit set to 1.
|
||
(ws-error process "Web Socket Fail: client must mask data"))
|
||
(cond
|
||
((= pl 126) (setq pl (bits-to-int (bits 2))))
|
||
((= pl 127) (setq pl (bits-to-int (bits 8)))))
|
||
;; unmask data
|
||
(when mask (setq mask-key (cl-subseq pending index (incf index 4))))
|
||
(setq data (concat data
|
||
(ws-web-socket-mask
|
||
mask-key (cl-subseq pending index (+ index pl)))))
|
||
(if fin
|
||
;; wipe the message state and call the handler
|
||
(let ((it data))
|
||
(setq data "" active nil pending "" new nil)
|
||
;; close on a close frame, otherwise call the handler
|
||
(if (not (eql opcode :CLOSE))
|
||
(funcall handler process it)
|
||
(process-send-string process
|
||
(unibyte-string (logior (lsh 1 7) 8) 0))))
|
||
;; add any remaining un-parsed network data to pending
|
||
(when (< (+ index pl) (length pending))
|
||
(setq pending (substring pending (+ index pl)))))))
|
||
;; possibly re-parse any pending input
|
||
(when (ws-new message) (ws-web-socket-parse-messages message)))))
|
||
|
||
(defun ws-web-socket-frame (string &optional opcode)
|
||
"Frame STRING for web socket communication."
|
||
(let* ((fin 1) ;; set to 0 if not final frame
|
||
(len (length string))
|
||
(opcode (ecase (or opcode :TEXT) (:TEXT 1) (:BINARY 2))))
|
||
;; Does not do any masking which is only required of client communication
|
||
(concat
|
||
(cond
|
||
((< len 126) (unibyte-string (logior (lsh fin 7) opcode) len))
|
||
((< len 65536) (unibyte-string (logior (lsh fin 7) opcode) 126
|
||
;; extended 16-bit length
|
||
(logand (lsh len -8) 255)
|
||
(logand len 255)))
|
||
(t (unibyte-string (logior (lsh fin 7) opcode) 127
|
||
;; more extended 64-bit length
|
||
(logand (lsh len -56) 255)
|
||
(logand (lsh len -48) 255)
|
||
(logand (lsh len -40) 255)
|
||
(logand (lsh len -32) 255)
|
||
(logand (lsh len -24) 255)
|
||
(logand (lsh len -16) 255)
|
||
(logand (lsh len -8) 255)
|
||
(logand len 255))))
|
||
string)))
|
||
|
||
|
||
;;; Content and Transfer encoding support
|
||
(defvar ws-compress-cmd "compress"
|
||
"Command used for the \"compress\" Content or Transfer coding.")
|
||
|
||
(defvar ws-deflate-cmd "zlib-flate -compress"
|
||
"Command used for the \"deflate\" Content or Transfer coding.")
|
||
|
||
(defvar ws-gzip-cmd "gzip"
|
||
"Command used for the \"gzip\" Content or Transfer coding.")
|
||
|
||
(defmacro ws-encoding-cmd-to-fn (cmd)
|
||
"Return a function which applies CMD to strings."
|
||
`(lambda (s)
|
||
(with-temp-buffer
|
||
(insert s)
|
||
(shell-command-on-region (point-min) (point-max) ,cmd nil 'replace)
|
||
(buffer-string))))
|
||
|
||
(defun ws-chunk (string)
|
||
"Convert STRING to a valid chunk for HTTP chunked Transfer-encoding."
|
||
(format "%x\r\n%s\r\n" (string-bytes string) string))
|
||
|
||
|
||
;;; Convenience functions to write responses
|
||
(defun ws-response-header (proc code &rest headers)
|
||
"Send the headers for an HTTP response to PROC.
|
||
CODE should be an HTTP status code, see `ws-status-codes' for a
|
||
list of known codes.
|
||
|
||
When \"Content-Encoding\" or \"Transfer-Encoding\" headers are
|
||
supplied any subsequent data written to PROC using `ws-send' will
|
||
be encoded appropriately including sending the appropriate data
|
||
upon the end of transmission for chunked transfer encoding.
|
||
|
||
For example with the header `(\"Content-Encoding\" . \"gzip\")',
|
||
any data subsequently written to PROC using `ws-send' will be
|
||
compressed using the command specified in `ws-gzip-cmd'."
|
||
;; update process to reflect any Content or Transfer encodings
|
||
(let ((content (cdr (assoc "Content-Encoding" headers)))
|
||
(transfer (cdr (assoc "Transfer-Encoding" headers))))
|
||
(when content
|
||
(set-process-plist proc
|
||
(append
|
||
(list :content-encoding
|
||
(ecase (intern content)
|
||
((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
|
||
((deflate x-deflate) (ws-encoding-cmd-to-fn ws-deflate-cmd))
|
||
((gzip x-gzip) (ws-encoding-cmd-to-fn ws-gzip-cmd))
|
||
(identity #'identity)
|
||
((exi pack200-zip)
|
||
(ws-error proc "`%s' Content-encoding not supported."
|
||
content))))
|
||
(process-plist proc))))
|
||
(when transfer
|
||
(set-process-plist proc
|
||
(append
|
||
(when (string= transfer "chunked") (list :ender "0\r\n\r\n"))
|
||
(list :transfer-encoding
|
||
(ecase (intern transfer)
|
||
(chunked #'ws-chunk)
|
||
((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
|
||
((deflate x-deflate) (ws-encoding-cmd-to-fn ws-deflate-cmd))
|
||
((gzip x-gzip) (ws-encoding-cmd-to-fn ws-gzip-cmd))))
|
||
(process-plist proc)))))
|
||
(let ((headers
|
||
(cons
|
||
(format "HTTP/1.1 %d %s" code (cdr (assoc code ws-status-codes)))
|
||
(mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) headers))))
|
||
(setcdr (last headers) (list "" ""))
|
||
(process-send-string proc (mapconcat #'identity headers "\r\n"))))
|
||
|
||
(defun ws-send (proc string)
|
||
"Send STRING to process PROC.
|
||
If any Content or Transfer encodings are in use, apply them to
|
||
STRING before sending."
|
||
(let
|
||
((cc (or (plist-get (process-plist proc) :content-encoding) #'identity))
|
||
(tc (or (plist-get (process-plist proc) :transfer-encoding) #'identity)))
|
||
(process-send-string proc (funcall tc (funcall cc string)))))
|
||
|
||
(defun ws-send-500 (proc &rest msg-and-args)
|
||
"Send 500 \"Internal Server Error\" to PROC with an optional message."
|
||
(ws-response-header proc 500
|
||
'("Content-type" . "text/plain"))
|
||
(process-send-string proc (if msg-and-args
|
||
(apply #'format msg-and-args)
|
||
"500 Internal Server Error"))
|
||
(throw 'close-connection nil))
|
||
|
||
(defun ws-send-404 (proc &rest msg-and-args)
|
||
"Send 404 \"Not Found\" to PROC with an optional message."
|
||
(ws-response-header proc 404
|
||
'("Content-type" . "text/plain"))
|
||
(process-send-string proc (if msg-and-args
|
||
(apply #'format msg-and-args)
|
||
"404 Not Found"))
|
||
(throw 'close-connection nil))
|
||
|
||
(defun ws-send-file (proc path &optional mime-type)
|
||
"Send PATH to PROC.
|
||
Optionally explicitly set MIME-TYPE, otherwise it is guessed by
|
||
`mm-default-file-encoding'."
|
||
(let ((mime (or mime-type
|
||
(mm-default-file-encoding path)
|
||
"application/octet-stream")))
|
||
(process-send-string proc
|
||
(with-temp-buffer
|
||
(insert-file-contents-literally path)
|
||
(ws-response-header proc 200
|
||
(cons "Content-type" mime)
|
||
(cons "Content-length" (- (point-max) (point-min))))
|
||
(buffer-string)))))
|
||
|
||
(defun ws-send-directory-list (proc directory &optional match)
|
||
"Send a listing of files in DIRECTORY to PROC.
|
||
Optional argument MATCH is passed to `directory-files' and may be
|
||
used to limit the files sent."
|
||
(ws-response-header proc 200 (cons "Content-type" "text/html"))
|
||
(process-send-string proc
|
||
(concat "<ul>"
|
||
(mapconcat (lambda (f)
|
||
(let* ((full (expand-file-name f directory))
|
||
(end (if (file-directory-p full) "/" ""))
|
||
(url (url-encode-url (concat f end))))
|
||
(format "<li><a href=%s>%s</li>" url f)))
|
||
(directory-files directory nil match)
|
||
"\n")
|
||
"</ul>")))
|
||
|
||
(defun ws-in-directory-p (parent path)
|
||
"Check if PATH is under the PARENT directory.
|
||
If so return PATH, if not return nil. Note: the PARENT directory
|
||
must be full expanded as with `expand-file-name' and should not
|
||
contain e.g., \"~\" for a user home directory."
|
||
(if (zerop (length path))
|
||
parent
|
||
(let ((expanded (expand-file-name path parent)))
|
||
(and (>= (length expanded) (length parent))
|
||
(string= parent (substring expanded 0 (length parent)))
|
||
expanded))))
|
||
|
||
(defun ws-with-authentication (handler credentials
|
||
&optional realm unauth invalid)
|
||
"Return a version of HANDLER protected by CREDENTIALS.
|
||
HANDLER should be a function as passed to `ws-start', and
|
||
CREDENTIALS should be an alist of elements of the form (USERNAME
|
||
. PASSWORD).
|
||
|
||
Optional argument REALM sets the realm in the authentication
|
||
challenge. Optional arguments UNAUTH and INVALID should be
|
||
functions which are called on the request when no authentication
|
||
information, or invalid authentication information are provided
|
||
respectively."
|
||
(lexical-let ((handler handler)
|
||
(credentials credentials)
|
||
(realm realm)
|
||
(unauth unauth)
|
||
(invalid invalid))
|
||
(lambda (request)
|
||
(with-slots (process headers) request
|
||
(let ((auth (cddr (assoc :AUTHORIZATION headers))))
|
||
(cond
|
||
;; no authentication information provided
|
||
((not auth)
|
||
(if unauth
|
||
(funcall unauth request)
|
||
(ws-response-header process 401
|
||
(cons "WWW-Authenticate"
|
||
(format "Basic realm=%S" (or realm "restricted")))
|
||
'("Content-type" . "text/plain"))
|
||
(process-send-string process "authentication required")))
|
||
;; valid authentication information
|
||
((string= (cdr auth) (cdr (assoc (car auth) credentials)))
|
||
(funcall handler request))
|
||
;; invalid authentication information
|
||
(t
|
||
(if invalid
|
||
(funcall invalid request)
|
||
(ws-response-header process 403 '("Content-type" . "text/plain"))
|
||
(process-send-string process "invalid credentials")))))))))
|
||
|
||
(defun ws-web-socket-handshake (key)
|
||
"Perform the handshake defined in RFC6455."
|
||
(base64-encode-string (sha1 (concat (ws-trim key) ws-guid) nil nil 'binary)))
|
||
|
||
;;; Enable the old accessors without the `ws-' namespace as obsolete.
|
||
;;; Lets plan to remove these within a year of the date they were
|
||
;;; marked obsolete, so that would be roughly 2021-03-12.
|
||
(define-obsolete-function-alias 'active 'ws-active "2020-03-12")
|
||
(define-obsolete-function-alias 'body 'ws-body "2020-03-12")
|
||
(define-obsolete-function-alias 'boundary 'ws-boundary "2020-03-12")
|
||
(define-obsolete-function-alias 'context 'ws-context "2020-03-12")
|
||
(define-obsolete-function-alias 'data 'ws-data "2020-03-12")
|
||
(define-obsolete-function-alias 'handler 'ws-handler "2020-03-12")
|
||
(define-obsolete-function-alias 'handlers 'ws-handlers "2020-03-12")
|
||
(define-obsolete-function-alias 'headers 'ws-headers "2020-03-12")
|
||
(define-obsolete-function-alias 'index 'ws-index "2020-03-12")
|
||
(define-obsolete-function-alias 'new 'ws-new "2020-03-12")
|
||
(define-obsolete-function-alias 'pending 'ws-pending "2020-03-12")
|
||
(define-obsolete-function-alias 'port 'ws-port "2020-03-12")
|
||
(define-obsolete-function-alias 'process 'ws-process "2020-03-12")
|
||
(define-obsolete-function-alias 'requests 'ws-requests "2020-03-12")
|
||
|
||
(provide 'web-server)
|
||
;;; web-server.el ends here
|