code.delx.au - gnu-emacs-elpa/blob - packages/web-server/web-server.el

   1 ;;; web-server.el --- Emacs Web Server
   2
   3 ;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Schulte <schulte.eric@gmail.com>
   6 ;; Maintainer: Eric Schulte <schulte.eric@gmail.com>
   7 ;; Version: 0.1.0
   8 ;; Package-Requires: ((emacs "24.3"))
   9 ;; Keywords: http, server, network
  10 ;; URL: https://github.com/eschulte/emacs-web-server
  11 ;; License: GPLV3 (see the COPYING file in this directory)
  12
  13 ;;; Commentary:
  14
  15 ;; A web server in Emacs running handlers written in Emacs Lisp.
  16 ;;
  17 ;; Full support for GET and POST requests including URL-encoded
  18 ;; parameters and multipart/form data.  Supports web sockets.
  19 ;;
  20 ;; See the examples/ directory for examples demonstrating the usage of
  21 ;; the Emacs Web Server.  The following launches a simple "hello
  22 ;; world" server.
  23 ;;
  24 ;;     (ws-start
  25 ;;      '(((lambda (_) t) .                         ; match every request
  26 ;;         (lambda (request)                        ; reply with "hello world"
  27 ;;           (with-slots (process) request
  28 ;;             (ws-response-header process 200 '("Content-type" . "text/plain"))
  29 ;;             (process-send-string process "hello world")))))
  30 ;;      9000)
  31
  32 ;;; Code:
  33 (require 'web-server-status-codes)
  34 (require 'mail-parse)             ; to parse multipart data in headers
  35 (require 'mm-encode)              ; to look-up mime types for files
  36 (require 'url-util)               ; to decode url-encoded params
  37 (require 'eieio)
  38 (eval-when-compile (require 'cl))
  39 (require 'cl-lib)
  40
  41 (defclass ws-server ()
  42   ((handlers :initarg :handlers :accessor handlers :initform nil)
  43    (process  :initarg :process  :accessor process  :initform nil)
  44    (port     :initarg :port     :accessor port     :initform nil)
  45    (requests :initarg :requests :accessor requests :initform nil)))
  46
  47 (defclass ws-request ()
  48   ((process  :initarg :process  :accessor process  :initform nil)
  49    (pending  :initarg :pending  :accessor pending  :initform "")
  50    (context  :initarg :context  :accessor context  :initform nil)
  51    (boundary :initarg :boundary :accessor boundary :initform nil)
  52    (index    :initarg :index    :accessor index    :initform 0)
  53    (active   :initarg :active   :accessor active   :initform nil)
  54    (headers  :initarg :headers  :accessor headers  :initform (list nil))))
  55
  56 (defvar ws-servers nil
  57   "List holding all web servers.")
  58
  59 (defvar ws-log-time-format "%Y.%m.%d.%H.%M.%S.%N"
  60   "Logging time format passed to `format-time-string'.")
  61
  62 (defvar ws-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
  63   "This GUID is defined in RFC6455.")
  64
  65 ;;;###autoload
  66 (defun ws-start (handlers port &optional log-buffer &rest network-args)
  67   "Start a server using HANDLERS and return the server object.
  68
  69 HANDLERS may be a single function (which is then called on every
  70 request) or a list of conses of the form (MATCHER . FUNCTION),
  71 where the FUNCTION associated with the first successful MATCHER
  72 is called.  Handler functions are called with two arguments, the
  73 process and the request object.
  74
  75 A MATCHER may be either a function (in which case it is called on
  76 the request object) or a cons cell of the form (KEYWORD . STRING)
  77 in which case STRING is matched against the value of the header
  78 specified by KEYWORD.
  79
  80 Any supplied NETWORK-ARGS are assumed to be keyword arguments for
  81 `make-network-process' to which they are passed directly.
  82
  83 For example, the following starts a simple hello-world server on
  84 port 8080.
  85
  86   (ws-start
  87    (lambda (request)
  88      (with-slots (process headers) request
  89        (process-send-string proc
  90         \"HTTP/1.1 200 OK\\r\\nContent-Type: text/plain\\r\\n\\r\\nhello world\")))
  91    8080)
  92
  93 Equivalently, the following starts an identical server using a
  94 function MATCH and the `ws-response-header' convenience
  95 function.
  96
  97   (ws-start
  98    '(((lambda (_) t) .
  99       (lambda (proc request)
 100         (ws-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
 101         (process-send-string proc \"hello world\")
 102         t)))
 103    8080)
 104
 105 "
 106   (let ((server (make-instance 'ws-server :handlers handlers :port port))
 107         (log (when log-buffer (get-buffer-create log-buffer))))
 108     (setf (process server)
 109           (apply
 110            #'make-network-process
 111            :name "ws-server"
 112            :service (port server)
 113            :filter 'ws-filter
 114            :server t
 115            :nowait t
 116            :family 'ipv4
 117            :plist (append (list :server server)
 118                           (when log (list :log-buffer log)))
 119            :log (when log
 120                   (lambda (proc request message)
 121                     (let ((c (process-contact request))
 122                           (buf (plist-get (process-plist proc) :log-buffer)))
 123                       (with-current-buffer buf
 124                         (goto-char (point-max))
 125                         (insert (format "%s\t%s\t%s\t%s"
 126                                         (format-time-string ws-log-time-format)
 127                                         (first c) (second c) message))))))
 128            network-args))
 129     (push server ws-servers)
 130     server))
 131
 132 (defun ws-stop (server)
 133   "Stop SERVER."
 134   (setq ws-servers (remove server ws-servers))
 135   (mapc #'delete-process (append (mapcar #'process (requests server))
 136                                  (list (process server)))))
 137
 138 (defun ws-stop-all ()
 139   "Stop all servers in `ws-servers'."
 140   (interactive)
 141   (mapc #'ws-stop ws-servers))
 142
 143 (defvar ws-http-common-methods '(GET HEAD POST PUT DELETE TRACE)
 144   "HTTP methods from http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html.")
 145
 146 (defvar ws-http-method-rx
 147   (format "^\\(%s\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$"
 148           (mapconcat #'symbol-name ws-http-common-methods "\\|")))
 149
 150 (defun ws-parse-query-string (string)
 151   "Thin wrapper around `url-parse-query-string'."
 152   (mapcar (lambda (pair) (cons (first pair) (second pair)))
 153           (url-parse-query-string string nil 'allow-newlines)))
 154
 155 (defun ws-parse (proc string)
 156   "Parse HTTP headers in STRING reporting errors to PROC."
 157   (cl-flet ((to-keyword (s) (intern (concat ":" (upcase s)))))
 158     (cond
 159      ;; Method
 160      ((string-match ws-http-method-rx string)
 161       (let ((method (to-keyword (match-string 1 string)))
 162             (url (match-string 2 string)))
 163         (if (string-match "?" url)
 164             (cons (cons method (substring url 0 (match-beginning 0)))
 165                   (ws-parse-query-string
 166                    (url-unhex-string (substring url (match-end 0)))))
 167           (list (cons method url)))))
 168      ;; Authorization
 169      ((string-match "^AUTHORIZATION: \\([^[:space:]]+\\) \\(.*\\)$" string)
 170       (let ((protocol (to-keyword (match-string 1 string)))
 171             (credentials (match-string 2 string)))
 172         (list (cons :AUTHORIZATION
 173                     (cons protocol
 174                           (case protocol
 175                             (:BASIC
 176                              (let ((cred (base64-decode-string credentials)))
 177                                (if (string-match ":" cred)
 178                                    (cons (substring cred 0 (match-beginning 0))
 179                                          (substring cred (match-end 0)))
 180                                  (ws-error proc "bad credentials: %S" cred))))
 181                             (t (ws-error proc "un-support protocol: %s"
 182                                          protocol))))))))
 183      ;; All other headers
 184      ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
 185       (list (cons (to-keyword (match-string 1 string))
 186                   (match-string 2 string))))
 187      (:otherwise (ws-error proc "bad header: %S" string) nil))))
 188
 189 (defun ws-trim (string)
 190   (while (and (> (length string) 0)
 191               (or (and (string-match "[\r\n]" (substring string -1))
 192                        (setq string (substring string 0 -1)))
 193                   (and (string-match "[\r\n]" (substring string 0 1))
 194                        (setq string (substring string 1))))))
 195   string)
 196
 197 (defun ws-parse-multipart/form (proc string)
 198   ;; ignore empty and non-content blocks
 199   (when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
 200     (let ((dp (cdr (mail-header-parse-content-disposition
 201                     (match-string 1 string))))
 202           (last-index (match-end 0))
 203           index)
 204       ;; every line up until the double \r\n is a header
 205       (while (and (setq index (string-match "\r\n" string last-index))
 206                   (not (= index last-index)))
 207         (setcdr (last dp) (ws-parse proc (substring string last-index index)))
 208         (setq last-index (+ 2 index)))
 209       ;; after double \r\n is all content
 210       (cons (cdr (assoc 'name dp))
 211             (cons (cons 'content (substring string (+ 2 last-index)))
 212                   dp)))))
 213
 214 (defun ws-filter (proc string)
 215   (with-slots (handlers requests) (plist-get (process-plist proc) :server)
 216     (unless (cl-find-if (lambda (c) (equal proc (process c))) requests)
 217       (push (make-instance 'ws-request :process proc) requests))
 218     (let ((request (cl-find-if (lambda (c) (equal proc (process c))) requests)))
 219       (with-slots (pending) request (setq pending (concat pending string)))
 220       (unless (active request) ; don't re-start if request is being parsed
 221         (setf (active request) t)
 222         (when (not (eq (catch 'close-connection
 223                          (if (ws-parse-request request)
 224                              (ws-call-handler request handlers)
 225                            :keep-alive))
 226                        :keep-alive))
 227           ;; Properly shut down processes requiring an ending (e.g., chunked)
 228           (let ((ender (plist-get (process-plist proc) :ender)))
 229             (when ender (process-send-string proc ender)))
 230           (setq requests (cl-remove-if (lambda (r) (eql proc (process r))) requests))
 231           (delete-process proc))))))
 232
 233 (defun ws-parse-request (request)
 234   "Parse request STRING from REQUEST with process PROC.
 235 Return non-nil only when parsing is complete."
 236   (catch 'finished-parsing-headers
 237     (with-slots (process pending context boundary headers index) request
 238       (let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
 239             ;; Track progress through string, always work with the
 240             ;; section of string between INDEX and NEXT-INDEX.
 241             next-index)
 242         ;; parse headers and append to request
 243         (while (setq next-index (string-match delimiter pending index))
 244           (let ((tmp (+ next-index (length delimiter))))
 245             (if (= index next-index) ; double \r\n ends current run of headers
 246                 (case context
 247                   ;; Parse URL data.
 248                   ;; http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4
 249                   (application/x-www-form-urlencoded
 250                    (mapc (lambda (pair) (setcdr (last headers) (list pair)))
 251                          (ws-parse-query-string
 252                           (replace-regexp-in-string
 253                            "\\+" " "
 254                            (ws-trim (substring pending index)))))
 255                    (throw 'finished-parsing-headers t))
 256                   ;; Set custom delimiter for multipart form data.
 257                   (multipart/form-data
 258                    (setq delimiter (concat "\r\n--" boundary)))
 259                   ;; No special context so we're done.
 260                   (t (throw 'finished-parsing-headers t)))
 261               (if (eql context 'multipart/form-data)
 262                   (progn
 263                     (setcdr (last headers)
 264                             (list (ws-parse-multipart/form process
 265                                     (substring pending index next-index))))
 266                     ;; Boundary suffixed by "--" indicates end of the headers.
 267                     (when (and (> (length pending) (+ tmp 2))
 268                                (string= (substring pending tmp (+ tmp 2)) "--"))
 269                       (throw 'finished-parsing-headers t)))
 270                 ;; Standard header parsing.
 271                 (let ((header (ws-parse process (substring pending
 272                                                            index next-index))))
 273                   ;; Content-Type indicates that the next double \r\n
 274                   ;; will be followed by a special type of content which
 275                   ;; will require special parsing.  Thus we will note
 276                   ;; the type in the CONTEXT variable for parsing
 277                   ;; dispatch above.
 278                   (if (and (caar header) (eql (caar header) :CONTENT-TYPE))
 279                       (cl-destructuring-bind (type &rest data)
 280                           (mail-header-parse-content-type (cdar header))
 281                         (setq boundary (cdr (assoc 'boundary data)))
 282                         (setq context (intern (downcase type))))
 283                     ;; All other headers are collected directly.
 284                     (setcdr (last headers) header)))))
 285             (setq index tmp)))))
 286     (setf (active request) nil)
 287     nil))
 288
 289 (defun ws-call-handler (request handlers)
 290   (catch 'matched-handler
 291     (when (functionp handlers)
 292       (throw 'matched-handler
 293              (condition-case e (funcall handlers request)
 294                (error (ws-error (process request) "Caught Error: %S" e)))))
 295     (mapc (lambda (handler)
 296             (let ((match (car handler))
 297                   (function (cdr handler)))
 298               (when (or (and (consp match)
 299                              (assoc (car match) (headers request))
 300                              (string-match (cdr match)
 301                                            (cdr (assoc (car match)
 302                                                        (headers request)))))
 303                         (and (functionp match) (funcall match request)))
 304                 (throw 'matched-handler
 305                        (condition-case e (funcall function request)
 306                          (error (ws-error (process request)
 307                                           "Caught Error: %S" e)))))))
 308           handlers)
 309     (ws-error (process request) "no handler matched request: %S"
 310               (headers request))))
 311
 312 (defun ws-error (proc msg &rest args)
 313   (let ((buf (plist-get (process-plist proc) :log-buffer))
 314         (c (process-contact proc)))
 315     (when buf
 316       (with-current-buffer buf
 317         (goto-char (point-max))
 318         (insert (format "%s\t%s\t%s\tWS-ERROR: %s"
 319                         (format-time-string ws-log-time-format)
 320                         (first c) (second c)
 321                         (apply #'format msg args)))))
 322     (apply #'ws-send-500 proc msg args)))
 323
 324 \f
 325 ;;; Web Socket
 326 ;; Implement to conform to http://tools.ietf.org/html/rfc6455.
 327
 328 ;; The `ws-message' object is used to hold state across multiple calls
 329 ;; of the process filter on the websocket network process.  The fields
 330 ;; play the following roles.
 331 ;; process ------ holds the process itself, used for communication
 332 ;; pending ------ holds text received from the client but not yet parsed
 333 ;; active ------- indicates that parsing is active to avoid re-entry
 334 ;;                of the `ws-web-socket-parse-messages' function
 335 ;; new ---------- indicates that new text was received during parsing
 336 ;;                and causes `ws-web-socket-parse-messages' to be
 337 ;;                called again after it terminates
 338 ;; data --------- holds the data of parsed messages
 339 ;; handler ------ holds the user-supplied function used called on the
 340 ;;                data of parsed messages
 341 (defclass ws-message ()                 ; web socket message object
 342   ((process  :initarg :process  :accessor process  :initform "")
 343    (pending  :initarg :pending  :accessor pending  :initform "")
 344    (active   :initarg :active   :accessor active   :initform nil)
 345    (new      :initarg :new      :accessor new      :initform nil)
 346    (data     :initarg :data     :accessor data     :initform "")
 347    (handler  :initarg :handler  :accessor handler  :initform "")))
 348
 349 (defun ws-web-socket-connect (request handler)
 350   "Establish a web socket connection with request.
 351 If the connection is successful this function will throw
 352 `:keep-alive' to `close-connection' skipping any remaining code
 353 in the request handler.  If no web-socket connection is
 354 established (e.g., because REQUEST is not attempting to establish
 355 a connection) then no actions are taken and nil is returned.
 356
 357 Second argument HANDLER should be a function of one argument
 358 which will be called on all complete messages as they are
 359 received and parsed from the network."
 360   (with-slots (process headers) request
 361     (when (assoc :SEC-WEBSOCKET-KEY headers)
 362       ;; Accept the connection
 363       (ws-response-header process 101
 364         (cons "Upgrade" "websocket")
 365         (cons "Connection" "upgrade")
 366         (cons "Sec-WebSocket-Accept"
 367               (ws-web-socket-handshake
 368                (cdr (assoc :SEC-WEBSOCKET-KEY headers)))))
 369       ;; Setup the process filter
 370       (set-process-coding-system process 'binary)
 371       (set-process-plist
 372        process (list :message (make-instance 'ws-message
 373                                 :handler handler :process process)))
 374       (set-process-filter process 'ws-web-socket-filter)
 375       process)))
 376
 377 (defun ws-web-socket-filter (process string)
 378   (let ((message (plist-get (process-plist process) :message)))
 379     (if (active message) ; don't re-start if message is being parsed
 380         (setf (new message) string)
 381       (setf (pending message) (concat (pending message) string))
 382       (setf (active message) t)
 383       (ws-web-socket-parse-messages message))
 384     (setf (active message) nil)))
 385
 386 (defun ws-web-socket-mask (masking-key data)
 387   (let ((masking-data (apply #'concat (make-list (+ 1 (/ (length data) 4))
 388                                                  masking-key))))
 389     (apply #'string (cl-mapcar #'logxor masking-data data))))
 390
 391 ;; Binary framing protocol
 392 ;; from http://tools.ietf.org/html/rfc6455#section-5.2
 393 ;;
 394 ;;  0                   1                   2                   3
 395 ;;  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
 396 ;; +-+-+-+-+-------+-+-------------+-------------------------------+
 397 ;; |F|R|R|R| opcode|M| Payload len |    Extended payload length    |
 398 ;; |I|S|S|S|  (4)  |A|     (7)     |             (16/64)           |
 399 ;; |N|V|V|V|       |S|             |   (if payload len==126/127)   |
 400 ;; | |1|2|3|       |K|             |                               |
 401 ;; +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
 402 ;; |     Extended payload length continued, if payload len == 127  |
 403 ;; + - - - - - - - - - - - - - - - +-------------------------------+
 404 ;; |                               |Masking-key, if MASK set to 1  |
 405 ;; +-------------------------------+-------------------------------+
 406 ;; | Masking-key (continued)       |          Payload Data         |
 407 ;; +-------------------------------- - - - - - - - - - - - - - - - +
 408 ;; :                     Payload Data continued ...                :
 409 ;; + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
 410 ;; |                     Payload Data continued ...                |
 411 ;; +---------------------------------------------------------------+
 412 ;;
 413 (defun ws-web-socket-parse-messages (message)
 414   "Web socket filter to pass whole frames to the client.
 415 See RFC6455."
 416   (with-slots (process active pending data handler new) message
 417     (let ((index 0))
 418       (cl-labels ((int-to-bits (int size)
 419                     (let ((result (make-bool-vector size nil)))
 420                       (mapc (lambda (place)
 421                               (let ((val (expt 2 place)))
 422                                 (when (>= int val)
 423                                   (setq int (- int val))
 424                                   (aset result place t))))
 425                             (reverse (number-sequence 0 (- size 1))))
 426                       (reverse (append result nil))))
 427                   (bits-to-int (bits)
 428                     (let ((place 0))
 429                       (apply #'+
 430                        (mapcar (lambda (bit)
 431                                  (prog1 (if bit (expt 2 place) 0) (incf place)))
 432                                (reverse bits)))))
 433                   (bits (length)
 434                     (apply #'append
 435                            (mapcar (lambda (int) (int-to-bits int 8))
 436                                    (cl-subseq
 437                                     pending index (incf index length))))))
 438         (let (fin rsvs opcode mask pl mask-key)
 439           ;; Parse fin bit, rsvs bits and opcode
 440           (let ((byte (bits 1)))
 441             (setq fin (car byte)
 442                   rsvs (cl-subseq byte 1 4)
 443                   opcode
 444                   (let ((it (bits-to-int (cl-subseq byte 4))))
 445                     (case it
 446                       (0 :CONTINUATION)
 447                       (1 :TEXT)
 448                       (2 :BINARY)
 449                       ((3 4 5 6 7) :NON-CONTROL)
 450                       (8 :CLOSE)
 451                       (9 :PING)
 452                       (10 :PONG)
 453                       ((11 12 13 14 15) :CONTROL)
 454                       ;; If an unknown opcode is received, the receiving
 455                       ;; endpoint MUST _Fail the WebSocket Connection_.
 456                       (t (ws-error process
 457                                    "Web Socket Fail: bad opcode %d" it))))))
 458           (unless (cl-every #'null rsvs)
 459             ;; MUST be 0 unless an extension is negotiated that defines
 460             ;; meanings for non-zero values.
 461             (ws-error process "Web Socket Fail: non-zero RSV 1 2 or 3"))
 462           ;; Parse mask and payload length
 463           (let ((byte (bits 1)))
 464             (setq mask (car byte)
 465                   pl (bits-to-int (cl-subseq byte 1))))
 466           (unless (eq mask t)
 467             ;; All frames sent from client to server have this bit set to 1.
 468             (ws-error process "Web Socket Fail: client must mask data"))
 469           (cond
 470            ((= pl 126) (setq pl (bits-to-int (bits 2))))
 471            ((= pl 127) (setq pl (bits-to-int (bits 8)))))
 472           ;; unmask data
 473           (when mask (setq mask-key (cl-subseq pending index (incf index 4))))
 474           (setq data (concat data
 475                              (ws-web-socket-mask
 476                               mask-key (cl-subseq pending index (+ index pl)))))
 477           (if fin
 478               ;; wipe the message state and call the handler
 479               (let ((it data))
 480                 (setq data "" active nil pending "" new nil)
 481                 ;; close on a close frame, otherwise call the handler
 482                 (if (not (eql opcode :CLOSE))
 483                     (funcall handler process it)
 484                   (process-send-string process
 485                     (unibyte-string (logior (lsh 1 7) 8) 0))))
 486             ;; add any remaining un-parsed network data to pending
 487             (when (< (+ index pl) (length pending))
 488               (setq pending (substring pending (+ index pl)))))))
 489       ;; possibly re-parse any pending input
 490       (when (new message) (ws-web-socket-parse-messages message)))))
 491
 492 (defun ws-web-socket-frame (string &optional opcode)
 493   "Frame STRING for web socket communication."
 494   (let* ((fin 1) ;; set to 0 if not final frame
 495          (len (length string))
 496          (opcode (ecase (or opcode :TEXT) (:TEXT 1) (:BINARY 2))))
 497     ;; Does not do any masking which is only required of client communication
 498     (concat
 499      (cond
 500       ((< len 126) (unibyte-string (logior (lsh fin 7) opcode) len))
 501       ((< len 65536) (unibyte-string (logior (lsh fin 7) opcode) 126
 502                                      ;; extended 16-bit length
 503                                      (logand (lsh len -8) 255)
 504                                      (logand      len     255)))
 505       (t (unibyte-string (logior (lsh fin 7) opcode) 127
 506                          ;; more extended 64-bit length
 507                          (logand (lsh len -56) 255)
 508                          (logand (lsh len -48) 255)
 509                          (logand (lsh len -40) 255)
 510                          (logand (lsh len -32) 255)
 511                          (logand (lsh len -24) 255)
 512                          (logand (lsh len -16) 255)
 513                          (logand (lsh len -8)  255)
 514                          (logand      len      255))))
 515      string)))
 516
 517 \f
 518 ;;; Content and Transfer encoding support
 519 (defvar ws-compress-cmd "compress"
 520   "Command used for the \"compress\" Content or Transfer coding.")
 521
 522 (defvar ws-deflate-cmd "zlib-flate -compress"
 523   "Command used for the \"deflate\" Content or Transfer coding.")
 524
 525 (defvar ws-gzip-cmd "gzip"
 526   "Command used for the \"gzip\" Content or Transfer coding.")
 527
 528 (defmacro ws-encoding-cmd-to-fn (cmd)
 529   "Return a function which applies CMD to strings."
 530   `(lambda (s)
 531      (with-temp-buffer
 532        (insert s)
 533        (shell-command-on-region (point-min) (point-max) ,cmd nil 'replace)
 534        (buffer-string))))
 535
 536 (defun ws-chunk (string)
 537   "Convert STRING to a valid chunk for HTTP chunked Transfer-encoding."
 538   (format "%x\r\n%s\r\n" (string-bytes string) string))
 539
 540 \f
 541 ;;; Convenience functions to write responses
 542 (defun ws-response-header (proc code &rest headers)
 543   "Send the headers for an HTTP response to PROC.
 544 CODE should be an HTTP status code, see `ws-status-codes' for a
 545 list of known codes.
 546
 547 When \"Content-Encoding\" or \"Transfer-Encoding\" headers are
 548 supplied any subsequent data written to PROC using `ws-send' will
 549 be encoded appropriately including sending the appropriate data
 550 upon the end of transmission for chunked transfer encoding.
 551
 552 For example with the header `(\"Content-Encoding\" . \"gzip\")',
 553 any data subsequently written to PROC using `ws-send' will be
 554 compressed using the command specified in `ws-gzip-cmd'."
 555   ;; update process to reflect any Content or Transfer encodings
 556   (let ((content  (cdr (assoc "Content-Encoding" headers)))
 557         (transfer (cdr (assoc "Transfer-Encoding" headers))))
 558     (when content
 559       (set-process-plist proc
 560         (append
 561          (list :content-encoding
 562                (ecase (intern content)
 563                  ((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
 564                  ((deflate x-deflate)   (ws-encoding-cmd-to-fn ws-deflate-cmd))
 565                  ((gzip x-gzip)         (ws-encoding-cmd-to-fn ws-gzip-cmd))
 566                  (identity #'identity)
 567                  ((exi pack200-zip)
 568                   (ws-error proc "`%s' Content-encoding not supported."
 569                             content))))
 570          (process-plist proc))))
 571     (when transfer
 572       (set-process-plist proc
 573         (append
 574          (when (string= transfer "chunked") (list :ender "0\r\n\r\n"))
 575          (list :transfer-encoding
 576                (ecase (intern transfer)
 577                  (chunked  #'ws-chunk)
 578                  ((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
 579                  ((deflate x-deflate)   (ws-encoding-cmd-to-fn ws-deflate-cmd))
 580                  ((gzip x-gzip)         (ws-encoding-cmd-to-fn ws-gzip-cmd))))
 581          (process-plist proc)))))
 582   (let ((headers
 583          (cons
 584           (format "HTTP/1.1 %d %s" code (cdr (assoc code ws-status-codes)))
 585           (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) headers))))
 586     (setcdr (last headers) (list "" ""))
 587     (process-send-string proc (mapconcat #'identity headers "\r\n"))))
 588
 589 (defun ws-send (proc string)
 590   "Send STRING to process PROC.
 591 If any Content or Transfer encodings are in use, apply them to
 592 STRING before sending."
 593   (let
 594       ((cc (or (plist-get (process-plist proc) :content-encoding) #'identity))
 595        (tc (or (plist-get (process-plist proc) :transfer-encoding) #'identity)))
 596     (process-send-string proc (funcall tc (funcall cc string)))))
 597
 598 (defun ws-send-500 (proc &rest msg-and-args)
 599   "Send 500 \"Internal Server Error\" to PROC with an optional message."
 600   (ws-response-header proc 500
 601     '("Content-type" . "text/plain"))
 602   (process-send-string proc (if msg-and-args
 603                                 (apply #'format msg-and-args)
 604                               "500 Internal Server Error"))
 605   (throw 'close-connection nil))
 606
 607 (defun ws-send-404 (proc &rest msg-and-args)
 608   "Send 404 \"Not Found\" to PROC with an optional message."
 609   (ws-response-header proc 404
 610     '("Content-type" . "text/plain"))
 611   (process-send-string proc (if msg-and-args
 612                                 (apply #'format msg-and-args)
 613                               "404 Not Found"))
 614   (throw 'close-connection nil))
 615
 616 (defun ws-send-file (proc path &optional mime-type)
 617   "Send PATH to PROC.
 618 Optionally explicitly set MIME-TYPE, otherwise it is guessed by
 619 `mm-default-file-encoding'."
 620   (let ((mime (or mime-type
 621                   (mm-default-file-encoding path)
 622                   "application/octet-stream")))
 623     (process-send-string proc
 624       (with-temp-buffer
 625         (insert-file-contents-literally path)
 626         (ws-response-header proc 200
 627           (cons "Content-type" mime)
 628           (cons "Content-length" (- (point-max) (point-min))))
 629         (buffer-string)))))
 630
 631 (defun ws-send-directory-list (proc directory &optional match)
 632   "Send a listing of files in DIRECTORY to PROC.
 633 Optional argument MATCH is passed to `directory-files' and may be
 634 used to limit the files sent."
 635   (ws-response-header proc 200 (cons "Content-type" "text/html"))
 636   (process-send-string proc
 637     (concat "<ul>"
 638             (mapconcat (lambda (f)
 639                          (let* ((full (expand-file-name f directory))
 640                                 (end (if (file-directory-p full) "/" ""))
 641                                 (url (url-encode-url (concat f end))))
 642                            (format "<li><a href=%s>%s</li>" url f)))
 643                        (directory-files directory nil match)
 644                        "\n")
 645             "</ul>")))
 646
 647 (defun ws-in-directory-p (parent path)
 648   "Check if PATH is under the PARENT directory.
 649 If so return PATH, if not return nil."
 650   (if (zerop (length path))
 651       parent
 652     (let ((expanded (expand-file-name path parent)))
 653       (and (>= (length expanded) (length parent))
 654            (string= parent (substring expanded 0 (length parent)))
 655            expanded))))
 656
 657 (defun ws-with-authentication (handler credentials
 658                                        &optional realm unauth invalid)
 659   "Return a version of HANDLER protected by CREDENTIALS.
 660 HANDLER should be a function as passed to `ws-start', and
 661 CREDENTIALS should be an alist of elements of the form (USERNAME
 662 . PASSWORD).
 663
 664 Optional argument REALM sets the realm in the authentication
 665 challenge.  Optional arguments UNAUTH and INVALID should be
 666 functions which are called on the request when no authentication
 667 information, or invalid authentication information are provided
 668 respectively."
 669   (lexical-let ((handler handler)
 670                 (credentials credentials)
 671                 (realm realm)
 672                 (unauth unauth)
 673                 (invalid invalid))
 674     (lambda (request)
 675       (with-slots (process headers) request
 676         (let ((auth (cddr (assoc :AUTHORIZATION headers))))
 677           (cond
 678            ;; no authentication information provided
 679            ((not auth)
 680             (if unauth
 681                 (funcall unauth request)
 682               (ws-response-header process 401
 683                 (cons "WWW-Authenticate"
 684                       (format "Basic realm=%S" (or realm "restricted")))
 685                 '("Content-type" . "text/plain"))
 686               (process-send-string process "authentication required")))
 687            ;; valid authentication information
 688            ((string= (cdr auth) (cdr (assoc (car auth) credentials)))
 689             (funcall handler request))
 690            ;; invalid authentication information
 691            (t
 692             (if invalid
 693                 (funcall invalid request)
 694               (ws-response-header process 403 '("Content-type" . "text/plain"))
 695               (process-send-string process "invalid credentials")))))))))
 696
 697 (defun ws-web-socket-handshake (key)
 698   "Perform the handshake defined in RFC6455."
 699   (base64-encode-string (sha1 (concat (ws-trim key) ws-guid) nil nil 'binary)))
 700
 701 (provide 'web-server)
 702 ;;; web-server.el ends here