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

   1 ;;; emacs-web-server.el --- Emacs Web Server
   2
   3 ;; Copyright (C) 2013 Eric Schulte <schulte.eric@gmail.com>
   4
   5 ;; Author: Eric Schulte <schulte.eric@gmail.com>
   6 ;; Keywords: http
   7 ;; License: GPLV3 (see the COPYING file in this directory)
   8
   9 ;;; Code:
  10 (require 'emacs-web-server-status-codes)
  11 (require 'mail-parse)             ; to parse multipart data in headers
  12 (require 'mm-encode)              ; to look-up mime types for files
  13 (require 'url-util)               ; to decode url-encoded params
  14 (require 'eieio)
  15 (eval-when-compile (require 'cl))
  16 (require 'cl-lib)
  17
  18 (defclass ews-server ()
  19   ((handler :initarg :handler :accessor handler :initform nil)
  20    (process :initarg :process :accessor process :initform nil)
  21    (port    :initarg :port    :accessor port    :initform nil)
  22    (clients :initarg :clients :accessor clients :initform nil)))
  23
  24 (defclass ews-client ()
  25   ((leftover :initarg :leftover :accessor leftover :initform "")
  26    (boundary :initarg :boundary :accessor boundary :initform nil)
  27    (headers  :initarg :headers  :accessor headers  :initform (list nil))))
  28
  29 (defvar ews-servers nil
  30   "List holding all ews servers.")
  31
  32 (defvar ews-time-format "%Y.%m.%d.%H.%M.%S.%N"
  33   "Logging time format passed to `format-time-string'.")
  34
  35 (defun ews-start (handler port &optional log-buffer &rest network-args)
  36   "Start a server using HANDLER and return the server object.
  37
  38 HANDLER should be a list of cons of the form (MATCH . ACTION),
  39 where MATCH is either a function (in which case it is called on
  40 the request object) or a cons cell of the form (KEYWORD . STRING)
  41 in which case STRING is matched against the value of the header
  42 specified by KEYWORD.  In either case when MATCH returns non-nil,
  43 then the function ACTION is called with two arguments, the
  44 process and the request object.
  45
  46 Any supplied NETWORK-ARGS are assumed to be keyword arguments for
  47 `make-network-process' to which they are passed directly.
  48
  49 For example, the following starts a simple hello-world server on
  50 port 8080.
  51
  52   (ews-start
  53    '(((:GET . \".*\") .
  54       (lambda (proc request)
  55         (process-send-string proc
  56          \"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhello world\r\n\")
  57         t)))
  58    8080)
  59
  60 Equivalently, the following starts an identical server using a
  61 function MATCH and the `ews-response-header' convenience
  62 function.
  63
  64   (ews-start
  65    '(((lambda (_) t) .
  66       (lambda (proc request)
  67         (ews-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
  68         (process-send-string proc \"hello world\")
  69         t)))
  70    8080)
  71
  72 "
  73   (let ((server (make-instance 'ews-server :handler handler :port port))
  74         (log (when log-buffer (get-buffer-create log-buffer))))
  75     (setf (process server)
  76           (apply
  77            #'make-network-process
  78            :name "ews-server"
  79            :service (port server)
  80            :filter 'ews-filter
  81            :server t
  82            :nowait t
  83            :family 'ipv4
  84            :plist (append (list :server server)
  85                           (when log (list :log-buffer log)))
  86            :log (when log
  87                   (lambda (proc client message)
  88                     (let ((c (process-contact client))
  89                           (buf (plist-get (process-plist proc) :log-buffer)))
  90                       (with-current-buffer buf
  91                         (goto-char (point-max))
  92                         (insert (format "%s\t%s\t%s\t%s"
  93                                         (format-time-string ews-time-format)
  94                                         (first c) (second c) message))))))
  95            network-args))
  96     (push server ews-servers)
  97     server))
  98
  99 (defun ews-stop (server)
 100   "Stop SERVER."
 101   (setq ews-servers (remove server ews-servers))
 102   (mapc #'delete-process (append (mapcar #'car (clients server))
 103                                  (list (process server)))))
 104
 105 (defvar ews-http-common-methods '(GET HEAD POST PUT DELETE TRACE)
 106   "HTTP methods from http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html.")
 107
 108 (defvar ews-http-method-rx
 109   (format "^\\(%s\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$"
 110           (mapconcat #'symbol-name ews-http-common-methods "\\|")))
 111
 112 (defun ews-parse (proc string)
 113   (cl-flet ((to-keyword (s) (intern (concat ":" (upcase (match-string 1 s))))))
 114     (cond
 115      ((string-match ews-http-method-rx string)
 116       (let ((method (to-keyword (match-string 1 string)))
 117             (url (match-string 2 string)))
 118         (if (string-match "?" url)
 119             (cons (cons method (substring url 0 (match-beginning 0)))
 120                   (url-parse-query-string (url-unhex-string
 121                                            (substring url (match-end 0))) ))
 122           (list (cons method url)))))
 123      ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
 124       (list (cons (to-keyword string) (match-string 2 string))))
 125      (:otherwise (ews-error proc "bad header: %S" string) nil))))
 126
 127 (defun ews-trim (string)
 128   (while (and (> (length string) 0)
 129               (or (and (string-match "[\r\n]" (substring string -1))
 130                        (setq string (substring string 0 -1)))
 131                   (and (string-match "[\r\n]" (substring string 0 1))
 132                        (setq string (substring string 1))))))
 133   string)
 134
 135 (defun ews-parse-multipart/form (string)
 136   ;; ignore empty and non-content blocks
 137   (when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
 138     (let ((dp (mail-header-parse-content-disposition (match-string 1 string))))
 139       (cons (cdr (assoc 'name (cdr dp)))
 140             (ews-trim (substring string (match-end 0)))))))
 141
 142 (defun ews-filter (proc string)
 143   (with-slots (handler clients) (plist-get (process-plist proc) :server)
 144     (unless (assoc proc clients)
 145       (push (cons proc (make-instance 'ews-client)) clients))
 146     (let ((c (cdr (assoc proc clients))))
 147       (when (not (eq (catch 'close-connection
 148                        (if (ews-do-filter proc c string)
 149                            (ews-call-handler proc (cdr (headers c)) handler)
 150                          :keep-open))
 151                      :keep-open))
 152         (setq clients (assq-delete-all proc clients))
 153         (delete-process proc)))))
 154
 155 (defun ews-do-filter (proc client string)
 156   "Return non-nil when finished and the client may be deleted."
 157   (with-slots (leftover boundary headers) client
 158     (let ((pending (concat leftover string))
 159           (delimiter (if boundary
 160                          (regexp-quote (concat "\r\n--" boundary))
 161                        "\r\n"))
 162           (last-index 0) index tmp-index)
 163       (catch 'finished-parsing-headers
 164         ;; parse headers and append to client
 165         (while (setq index (string-match delimiter pending last-index))
 166           (let ((tmp (+ index (length delimiter))))
 167             (cond
 168              ;; Double \r\n outside of post data means we are done
 169              ;; w/headers and should call the handler.
 170              ((and (not boundary) (= last-index index))
 171               (throw 'finished-parsing-headers t))
 172              ;; Parse a URL
 173              ((eq boundary :application/x-www-form-urlencoded)
 174               (mapc (lambda (pair) (setcdr (last headers) (list pair)))
 175                     (url-parse-query-string
 176                      (ews-trim (substring pending last-index))))
 177               (throw 'finished-parsing-headers t))
 178              ;; Build up multipart data.
 179              (boundary
 180               (setcdr (last headers)
 181                       (list (ews-parse-multipart/form
 182                              (ews-trim
 183                               (substring pending last-index index)))))
 184               ;; a boundary suffixed by "--" indicates the end of the headers
 185               (when (and (> (length pending) (+ tmp 2))
 186                          (string= (substring pending tmp (+ tmp 2)) "--"))
 187                 (throw 'finished-parsing-headers t)))
 188              ;; Standard header parsing.
 189              (:otherwise
 190               (let ((this (ews-parse proc (substring pending last-index index))))
 191                 (if (and (caar this) (eql (caar this) :CONTENT-TYPE))
 192                     (cl-destructuring-bind (type &rest data)
 193                         (mail-header-parse-content-type (cdar this))
 194                       (cond
 195                        ((string= type "multipart/form-data")
 196                         (when (assoc 'boundary data)
 197                           (setq boundary (cdr (assoc 'boundary data)))
 198                           (setq delimiter (concat "\r\n--" boundary))))
 199                        ((string= type "application/x-www-form-urlencoded")
 200                         (setq boundary (intern (concat ":" (downcase type)))))
 201                        (:otherwise
 202                         (ews-error proc "TODO: handle content type: %S" type))))
 203                   (setcdr (last headers) this)))))
 204             (setq last-index tmp)))
 205         (setq leftover (ews-trim (substring pending last-index)))
 206         nil))))
 207
 208 (defun ews-call-handler (proc request handler)
 209   (catch 'matched-handler
 210     (mapc (lambda (handler)
 211             (let ((match (car handler))
 212                   (function (cdr handler)))
 213               (when (or (and (consp match)
 214                              (assoc (car match) request)
 215                              (string-match (cdr match)
 216                                            (cdr (assoc (car match) request))))
 217                         (and (functionp match) (funcall match request)))
 218                 (throw 'matched-handler
 219                        (condition-case e
 220                            (funcall function proc request)
 221                          (error (ews-error proc "Caught Error: %S" e)))))))
 222           handler)
 223     (ews-error proc "no handler matched request: %S" request)))
 224
 225 (defun ews-error (proc msg &rest args)
 226   (let ((buf (plist-get (process-plist proc) :log-buffer))
 227         (c (process-contact proc)))
 228     (when buf
 229       (with-current-buffer buf
 230         (goto-char (point-max))
 231         (insert (format "%s\t%s\t%s\tEWS-ERROR: %s"
 232                         (format-time-string ews-time-format)
 233                         (first c) (second c)
 234                         (apply #'format msg args)))))
 235     (apply #'ews-send-500 proc msg args)))
 236
 237 \f
 238 ;;; Convenience functions to write responses
 239 (defun ews-response-header (proc code &rest header)
 240   "Send the headers for an HTTP response to PROC.
 241 Currently CODE should be an HTTP status code, see
 242 `ews-status-codes' for a list of known codes."
 243   (let ((headers
 244          (cons
 245           (format "HTTP/1.1 %d %s" code (cdr (assoc code ews-status-codes)))
 246           (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) header))))
 247     (setcdr (last headers) (list "" ""))
 248     (process-send-string proc (mapconcat #'identity headers "\r\n"))))
 249
 250 (defun ews-send-500 (proc &rest msg-and-args)
 251   "Send 500 \"Internal Server Error\" to PROC with an optional message."
 252   (ews-response-header proc 500
 253     '("Content-type" . "text/plain"))
 254   (process-send-string proc (if msg-and-args
 255                                 (apply #'format msg-and-args)
 256                               "500 Internal Server Error"))
 257   (throw 'close-connection nil))
 258
 259 (defun ews-send-404 (proc &rest msg-and-args)
 260   "Send 404 \"Not Found\" to PROC with an optional message."
 261   (ews-response-header proc 404
 262     '("Content-type" . "text/plain"))
 263   (process-send-string proc (if msg-and-args
 264                                 (apply #'format msg-and-args)
 265                               "404 Not Found"))
 266   (throw 'close-connection nil))
 267
 268 (defun ews-send-file (proc path &optional mime-type)
 269   "Send PATH to PROC.
 270 Optionally explicitly set MIME-TYPE, otherwise it is guessed by
 271 `mm-default-file-encoding'."
 272   (let ((mime (or mime-type
 273                   (mm-default-file-encoding path)
 274                   "application/octet-stream")))
 275     (ews-response-header proc 200 (cons "Content-type" mime))
 276     (process-send-string proc
 277       (with-temp-buffer
 278         (insert-file-contents-literally path)
 279         (buffer-string)))))
 280
 281 (provide 'emacs-web-server)
 282 ;;; emacs-web-server.el ends here