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