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   ((handlers :initarg :handlers :accessor handlers :initform nil)
  20    (process  :initarg :process  :accessor process  :initform nil)
  21    (port     :initarg :port     :accessor port     :initform nil)
  22    (requests :initarg :requests :accessor requests :initform nil)))
  23
  24 (defclass ews-request ()
  25   ((process  :initarg :process  :accessor process  :initform nil)
  26    (pending  :initarg :pending  :accessor pending  :initform "")
  27    (boundary :initarg :boundary :accessor boundary :initform nil)
  28    (headers  :initarg :headers  :accessor headers  :initform (list nil))))
  29
  30 (defvar ews-servers nil
  31   "List holding all ews servers.")
  32
  33 (defvar ews-log-time-format "%Y.%m.%d.%H.%M.%S.%N"
  34   "Logging time format passed to `format-time-string'.")
  35
  36 (defun ews-start (handlers port &optional log-buffer &rest network-args)
  37   "Start a server using HANDLERS and return the server object.
  38
  39 HANDLERS should be a list of cons of the form (MATCH . ACTION),
  40 where MATCH is either a function (in which case it is called on
  41 the request object) or a cons cell of the form (KEYWORD . STRING)
  42 in which case STRING is matched against the value of the header
  43 specified by KEYWORD.  In either case when MATCH returns non-nil,
  44 then the function ACTION is called with two arguments, the
  45 process and the request object.
  46
  47 Any supplied NETWORK-ARGS are assumed to be keyword arguments for
  48 `make-network-process' to which they are passed directly.
  49
  50 For example, the following starts a simple hello-world server on
  51 port 8080.
  52
  53   (ews-start
  54    '(((:GET . \".*\") .
  55       (lambda (proc request)
  56         (process-send-string proc
  57          \"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhello world\r\n\")
  58         t)))
  59    8080)
  60
  61 Equivalently, the following starts an identical server using a
  62 function MATCH and the `ews-response-header' convenience
  63 function.
  64
  65   (ews-start
  66    '(((lambda (_) t) .
  67       (lambda (proc request)
  68         (ews-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
  69         (process-send-string proc \"hello world\")
  70         t)))
  71    8080)
  72
  73 "
  74   (let ((server (make-instance 'ews-server :handlers handlers :port port))
  75         (log (when log-buffer (get-buffer-create log-buffer))))
  76     (setf (process server)
  77           (apply
  78            #'make-network-process
  79            :name "ews-server"
  80            :service (port server)
  81            :filter 'ews-filter
  82            :server t
  83            :nowait t
  84            :family 'ipv4
  85            :plist (append (list :server server)
  86                           (when log (list :log-buffer log)))
  87            :log (when log
  88                   (lambda (proc request message)
  89                     (let ((c (process-contact request))
  90                           (buf (plist-get (process-plist proc) :log-buffer)))
  91                       (with-current-buffer buf
  92                         (goto-char (point-max))
  93                         (insert (format "%s\t%s\t%s\t%s"
  94                                         (format-time-string ews-log-time-format)
  95                                         (first c) (second c) message))))))
  96            network-args))
  97     (push server ews-servers)
  98     server))
  99
 100 (defun ews-stop (server)
 101   "Stop SERVER."
 102   (setq ews-servers (remove server ews-servers))
 103   (mapc #'delete-process (append (mapcar #'car (requests server))
 104                                  (list (process server)))))
 105
 106 (defvar ews-http-common-methods '(GET HEAD POST PUT DELETE TRACE)
 107   "HTTP methods from http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html.")
 108
 109 (defvar ews-http-method-rx
 110   (format "^\\(%s\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$"
 111           (mapconcat #'symbol-name ews-http-common-methods "\\|")))
 112
 113 (defun ews-parse-query-string (string)
 114   "Thin wrapper around `url-parse-query-string'."
 115   (mapcar (lambda (pair) (cons (first pair) (second pair)))
 116           (url-parse-query-string string nil 'allow-newlines)))
 117
 118 (defun ews-parse (proc string)
 119   (cl-flet ((to-keyword (s) (intern (concat ":" (upcase (match-string 1 s))))))
 120     (cond
 121      ((string-match ews-http-method-rx string)
 122       (let ((method (to-keyword (match-string 1 string)))
 123             (url (match-string 2 string)))
 124         (if (string-match "?" url)
 125             (cons (cons method (substring url 0 (match-beginning 0)))
 126                   (ews-parse-query-string
 127                    (url-unhex-string (substring url (match-end 0)))))
 128           (list (cons method url)))))
 129      ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
 130       (list (cons (to-keyword string) (match-string 2 string))))
 131      (:otherwise (ews-error proc "bad header: %S" string) nil))))
 132
 133 (defun ews-trim (string)
 134   (while (and (> (length string) 0)
 135               (or (and (string-match "[\r\n]" (substring string -1))
 136                        (setq string (substring string 0 -1)))
 137                   (and (string-match "[\r\n]" (substring string 0 1))
 138                        (setq string (substring string 1))))))
 139   string)
 140
 141 (defun ews-parse-multipart/form (string)
 142   ;; ignore empty and non-content blocks
 143   (when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
 144     (let ((dp (mail-header-parse-content-disposition (match-string 1 string))))
 145       (cons (cdr (assoc 'name (cdr dp)))
 146             (ews-trim (substring string (match-end 0)))))))
 147
 148 (defun ews-filter (proc string)
 149   (with-slots (handlers requests) (plist-get (process-plist proc) :server)
 150     (unless (cl-find-if (lambda (c) (equal proc (process c))) requests)
 151       (push (make-instance 'ews-request :process proc) requests))
 152     (let ((request (cl-find-if (lambda (c) (equal proc (process c))) requests)))
 153       (with-slots (pending) request (setq pending (concat pending string)))
 154       (when (not (eq (catch 'close-connection
 155                        (if (ews-parse-request request string)
 156                            (ews-call-handler request handlers)
 157                            :keep-open))
 158                      :keep-open))
 159         (setq requests (cl-remove-if (lambda (r) (eql proc (process r))) requests))
 160         (delete-process proc)))))
 161
 162 (defun ews-parse-request (request string)
 163   "Parse request STRING from REQUEST with process PROC.
 164 Return non-nil only when parsing is complete."
 165   (with-slots (process pending boundary headers) request
 166     (setq pending (concat pending string))
 167     (let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
 168           ;; Track progress through string, always work with the
 169           ;; section of string between LAST-INDEX and INDEX.
 170           (last-index 0) index
 171           ;; Current context, either a particular content-type for
 172           ;; custom parsing or nil for no special parsing.
 173           context)
 174       (catch 'finished-parsing-headers
 175         ;; parse headers and append to request
 176         (while (setq index (string-match delimiter pending last-index))
 177           (let ((tmp (+ index (length delimiter))))
 178             (if (= last-index index) ; double \r\n ends current run of headers
 179                 (case context
 180                   ;; Parse URL data.
 181                   ;; http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4
 182                   (application/x-www-form-urlencoded
 183                    (mapc (lambda (pair) (setcdr (last headers) (list pair)))
 184                          (ews-parse-query-string
 185                           (replace-regexp-in-string
 186                            "\\+" " "
 187                            (ews-trim (substring pending last-index)))))
 188                    (throw 'finished-parsing-headers t))
 189                   ;; Set custom delimiter for multipart form data.
 190                   (multipart/form-data
 191                    (setq delimiter (concat "\r\n--" boundary)))
 192                   ;; No special context so we're done.
 193                   (t (throw 'finished-parsing-headers t)))
 194               (if (eql context 'multipart/form-data)
 195                   (progn
 196                     (setcdr (last headers)
 197                             (list (ews-parse-multipart/form
 198                                    (ews-trim
 199                                     (substring pending last-index index)))))
 200                     ;; Boundary suffixed by "--" indicates end of the headers.
 201                     (when (and (> (length pending) (+ tmp 2))
 202                                (string= (substring pending tmp (+ tmp 2)) "--"))
 203                       (throw 'finished-parsing-headers t)))
 204                 ;; Standard header parsing.
 205                 (let ((header (ews-parse process (substring pending
 206                                                             last-index index))))
 207                   ;; Content-Type indicates that the next double \r\n
 208                   ;; will be followed by a special type of content which
 209                   ;; will require special parsing.  Thus we will note
 210                   ;; the type in the CONTEXT variable for parsing
 211                   ;; dispatch above.
 212                   (if (and (caar header) (eql (caar header) :CONTENT-TYPE))
 213                       (cl-destructuring-bind (type &rest data)
 214                           (mail-header-parse-content-type (cdar header))
 215                         (setq boundary (cdr (assoc 'boundary data)))
 216                         (setq context (intern (downcase type))))
 217                     ;; All other headers are collected directly.
 218                     (setcdr (last headers) header)))))
 219             (setq last-index tmp)))
 220         (setq pending (ews-trim (substring pending last-index)))
 221         nil))))
 222
 223  (defun ews-call-handler (request handlers)
 224   (catch 'matched-handler
 225     (mapc (lambda (handler)
 226             (let ((match (car handler))
 227                   (function (cdr handler)))
 228               (when (or (and (consp match)
 229                              (assoc (car match) (headers request))
 230                              (string-match (cdr match)
 231                                            (cdr (assoc (car match)
 232                                                        (headers request)))))
 233                         (and (functionp match) (funcall match request)))
 234                 (throw 'matched-handler
 235                        (condition-case e (funcall function request)
 236                          (error (ews-error (process request)
 237                                            "Caught Error: %S" e)))))))
 238           handlers)
 239     (ews-error (process request) "no handler matched request: %S"
 240                (headers request))))
 241
 242 (defun ews-error (proc msg &rest args)
 243   (let ((buf (plist-get (process-plist proc) :log-buffer))
 244         (c (process-contact proc)))
 245     (when buf
 246       (with-current-buffer buf
 247         (goto-char (point-max))
 248         (insert (format "%s\t%s\t%s\tEWS-ERROR: %s"
 249                         (format-time-string ews-log-time-format)
 250                         (first c) (second c)
 251                         (apply #'format msg args)))))
 252     (apply #'ews-send-500 proc msg args)))
 253
 254 \f
 255 ;;; Convenience functions to write responses
 256 (defun ews-response-header (proc code &rest header)
 257   "Send the headers for an HTTP response to PROC.
 258 Currently CODE should be an HTTP status code, see
 259 `ews-status-codes' for a list of known codes."
 260   (let ((headers
 261          (cons
 262           (format "HTTP/1.1 %d %s" code (cdr (assoc code ews-status-codes)))
 263           (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) header))))
 264     (setcdr (last headers) (list "" ""))
 265     (process-send-string proc (mapconcat #'identity headers "\r\n"))))
 266
 267 (defun ews-send-500 (proc &rest msg-and-args)
 268   "Send 500 \"Internal Server Error\" to PROC with an optional message."
 269   (ews-response-header proc 500
 270     '("Content-type" . "text/plain"))
 271   (process-send-string proc (if msg-and-args
 272                                 (apply #'format msg-and-args)
 273                               "500 Internal Server Error"))
 274   (throw 'close-connection nil))
 275
 276 (defun ews-send-404 (proc &rest msg-and-args)
 277   "Send 404 \"Not Found\" to PROC with an optional message."
 278   (ews-response-header proc 404
 279     '("Content-type" . "text/plain"))
 280   (process-send-string proc (if msg-and-args
 281                                 (apply #'format msg-and-args)
 282                               "404 Not Found"))
 283   (throw 'close-connection nil))
 284
 285 (defun ews-send-file (proc path &optional mime-type)
 286   "Send PATH to PROC.
 287 Optionally explicitly set MIME-TYPE, otherwise it is guessed by
 288 `mm-default-file-encoding'."
 289   (let ((mime (or mime-type
 290                   (mm-default-file-encoding path)
 291                   "application/octet-stream")))
 292     (ews-response-header proc 200 (cons "Content-type" mime))
 293     (process-send-string proc
 294       (with-temp-buffer
 295         (insert-file-contents-literally path)
 296         (buffer-string)))))
 297
 298 (defun ews-subdirectoryp (parent path)
 299   "Check that PATH is a subdirectory of PARENT.
 300 If so return PATH, if not return nil."
 301   (let* ((expanded (expand-file-name path))
 302          (complete (if (string= (substring expanded -1) "/")
 303                        expanded
 304                      (concat expanded "/"))))
 305     (and (>= (length complete) (length parent))
 306          (string= parent (substring complete 0 (length parent)))
 307          complete)))
 308
 309 (provide 'emacs-web-server)
 310 ;;; emacs-web-server.el ends here