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