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 (defvar ews-servers nil
  22   "List holding all ews servers.")
  23
  24 (defvar ews-time-format "%Y.%m.%d.%H.%M.%S.%N"
  25   "Logging time format passed to `format-time-string'.")
  26
  27 (defun ews-start (handler port &optional log-buffer host)
  28   "Start a server using HANDLER and return the server object.
  29
  30 HANDLER should be a list of cons of the form (MATCH . ACTION),
  31 where MATCH is either a function (in which case it is called on
  32 the request object) or a cons cell of the form (KEYWORD . STRING)
  33 in which case STRING is matched against the value of the header
  34 specified by KEYWORD.  In either case when MATCH returns non-nil,
  35 then the function ACTION is called with two arguments, the
  36 process and the request object.
  37
  38 For example, the following starts a simple hello-world server on
  39 port 8080.
  40
  41   (ews-start
  42    '(((:GET . \".*\") .
  43       (lambda (proc request)
  44         (process-send-string proc
  45          \"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhello world\r\n\")
  46         t)))
  47    8080)
  48
  49 Equivalently, the following starts an identical server using a
  50 function MATCH and the `ews-response-header' convenience
  51 function.
  52
  53   (ews-start
  54    '(((lambda (_) t) .
  55       (lambda (proc request)
  56         (ews-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
  57         (process-send-string proc \"hello world\")
  58         t)))
  59    8080)
  60
  61 "
  62   (let ((server (make-instance 'ews-server :handler handler :port port)))
  63     (setf (process server)
  64           (make-network-process
  65            :name "ews-server"
  66            :service (port server)
  67            :filter 'ews-filter
  68            :server 't
  69            :nowait 't
  70            :family 'ipv4
  71            :host host
  72            :plist (list :server server)
  73            :log (when log-buffer
  74                   (lexical-let ((buf log-buffer))
  75                     (lambda (server client message)
  76                       (let ((c (process-contact client)))
  77                         (with-current-buffer buf
  78                           (goto-char (point-max))
  79                           (insert (format "%s\t%s\t%s\t%s"
  80                                           (format-time-string ews-time-format)
  81                                           (first c) (second c) message)))))))))
  82     (push server ews-servers)
  83     server))
  84
  85 (defun ews-stop (server)
  86   "Stop SERVER."
  87   (setq ews-servers (remove server ews-servers))
  88   (mapc #'delete-process (append (mapcar #'car (clients server))
  89                                  (list (process server)))))
  90
  91 (defun ews-parse (string)
  92   (cond
  93    ((string-match "^GET \\([^[:space:]]+\\) \\([^[:space:]]+\\)$" string)
  94     (list (cons :GET (match-string 1 string))
  95           (cons :TYPE (match-string 2 string))))
  96    ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
  97     (list (cons (intern (concat ":" (upcase (match-string 1 string))))
  98                 (match-string 2 string))))
  99    (:otherwise (message "[ews] bad header: %S" string) nil)))
 100
 101 (defun ews-filter (proc string)
 102   ;; TODO: parse post DATA, see the relevent test, and use these
 103   ;;   - mail-header-parse-content-disposition
 104   ;;   - mail-header-parse-content-type
 105   (with-slots (handler clients) (plist-get (process-plist proc) :server)
 106     ;; register new client
 107     (unless (assoc proc clients) (push (list proc "") clients))
 108     (let* ((client (assoc proc clients)) ; clients are (proc pending headers)
 109            (pending (concat (cadr client) string))
 110            (last-index 0) index in-post)
 111       (catch 'finished-parsing-headers
 112         ;; parse headers and append to client
 113         (while (setq index (string-match "\r\n" pending last-index))
 114           ;; double \r\n outside of post data -> done w/headers, call handler
 115           (when (and (not in-post) (= last-index index))
 116             (throw 'finished-parsing-headers
 117                    (when (ews-call-handler proc (cddr client) handler)
 118                      (setq clients (assq-delete-all proc clients))
 119                      (delete-process proc))))
 120           (if in-post
 121               ;; build up post data, maybe set in-post to boundary
 122               (error "TODO: handle POST data")
 123             (let ((this (ews-parse (substring pending last-index index))))
 124               (if (eql (caar this) :CONTENT-TYPE)
 125                   (error "TODO: handle POST data")
 126                 (setcdr (last client) this))))
 127           (setq last-index (+ index 2)))
 128         (setcar (cdr client) (substring pending last-index))))))
 129
 130 (defun ews-call-handler (proc request handler)
 131   (catch 'matched-handler
 132     (mapc (lambda (handler)
 133             (let ((match (car handler))
 134                   (function (cdr handler)))
 135               (when (or (and (consp match)
 136                              (assoc (car match) request)
 137                              (string-match (cdr match)
 138                                            (cdr (assoc (car match) request))))
 139                         (and (functionp match) (funcall match request)))
 140                 (throw 'matched-handler (funcall function proc request)))))
 141           handler)
 142     (error "[ews] no handler matched request:%S" request)))
 143
 144 \f
 145 ;;; Convenience functions to write responses
 146 (defun ews-response-header (proc code &rest header)
 147   "Send the headers for an HTTP response to PROC.
 148 Currently CODE should be an HTTP status code, see
 149 `ews-status-codes' for a list of known codes."
 150   (let ((headers
 151          (cons
 152           (format "HTTP/1.1 %d %s" code (cdr (assoc code ews-status-codes)))
 153           (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) header))))
 154     (setcdr (last headers) (list "" ""))
 155     (process-send-string proc (mapconcat #'identity headers "\r\n"))))
 156
 157 (provide 'emacs-web-server)
 158 ;;; emacs-web-server.el ends here