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

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