1 ;;; emacs-web-server.el --- Emacs Web Server
3 ;; Copyright (C) 2013 Eric Schulte <schulte.eric@gmail.com>
5 ;; Author: Eric Schulte <schulte.eric@gmail.com>
7 ;; License: GPLV3 (see the COPYING file in this directory)
10 (require 'emacs-web-server-status-codes)
13 (eval-when-compile (require 'cl))
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)))
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))))
27 (defvar ews-servers nil
28 "List holding all ews servers.")
30 (defvar ews-time-format "%Y.%m.%d.%H.%M.%S.%N"
31 "Logging time format passed to `format-time-string'.")
33 (defun ews-start (handler port &optional log-buffer &rest network-args)
34 "Start a server using HANDLER and return the server object.
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.
44 Any supplied NETWORK-ARGS are assumed to be keyword arguments for
45 `make-network-process' to which they are passed directly.
47 For example, the following starts a simple hello-world server on
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\")
58 Equivalently, the following starts an identical server using a
59 function MATCH and the `ews-response-header' convenience
64 (lambda (proc request)
65 (ews-response-header proc 200 '(\"Content-type\" . \"text/plain\"))
66 (process-send-string proc \"hello world\")
71 (let ((server (make-instance 'ews-server :handler handler :port port)))
72 (setf (process server)
74 #'make-network-process
76 :service (port server)
81 :plist (list :server server)
83 (lexical-let ((buf log-buffer))
84 (lambda (server client message)
85 (let ((c (process-contact client)))
86 (with-current-buffer buf
87 (goto-char (point-max))
88 (insert (format "%s\t%s\t%s\t%s"
89 (format-time-string ews-time-format)
90 (first c) (second c) message)))))))
92 (push server ews-servers)
95 (defun ews-stop (server)
97 (setq ews-servers (remove server ews-servers))
98 (mapc #'delete-process (append (mapcar #'car (clients server))
99 (list (process server)))))
101 (defun ews-parse (string)
102 (cl-flet ((to-keyword (s) (intern (concat ":" (upcase (match-string 1 s))))))
105 "^\\(GET\\|POST\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$" string)
106 (list (cons (to-keyword (match-string 1 string)) (match-string 2 string))
107 (cons :TYPE (match-string 3 string))))
108 ((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
109 (list (cons (to-keyword string) (match-string 2 string))))
110 (:otherwise (error "[ews] bad header: %S" string) nil))))
112 (defun ews-trim (string)
113 (while (and (> (length string) 0)
114 (or (and (string-match "[\r\n]" (substring string -1))
115 (setq string (substring string 0 -1)))
116 (and (string-match "[\r\n]" (substring string 0 1))
117 (setq string (substring string 1))))))
120 (defun ews-parse-multipart/form (string)
121 ;; ignore empty and non-content blocks
122 (when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
123 (let ((dp (mail-header-parse-content-disposition (match-string 1 string))))
124 (cons (cdr (assoc 'name (cdr dp)))
125 (cons (cons 'content (ews-trim (substring string (match-end 0))))
128 (defun ews-filter (proc string)
129 (with-slots (handler clients) (plist-get (process-plist proc) :server)
130 (unless (assoc proc clients)
131 (push (cons proc (make-instance 'ews-client)) clients))
132 (let ((client (cdr (assoc proc clients))))
133 (when (ews-do-filter client string)
134 (when (ews-call-handler proc (cdr (headers client)) handler)
135 (setq clients (assq-delete-all proc clients))
136 (delete-process proc))))))
138 (defun ews-do-filter (client string)
139 "Return non-nil when finished and the client may be deleted."
140 (with-slots (leftover boundary headers) client
141 (let ((pending (concat leftover string))
142 (delimiter (if boundary
143 (regexp-quote (concat "\r\n--" boundary))
145 (last-index 0) index tmp-index)
146 (catch 'finished-parsing-headers
147 ;; parse headers and append to client
148 (while (setq index (string-match delimiter pending last-index))
149 (let ((tmp (+ index (length delimiter))))
151 ;; Double \r\n outside of post data means we are done
152 ;; w/headers and should call the handler.
153 ((= last-index index)
154 (throw 'finished-parsing-headers t))
155 ;; Build up multipart data.
157 (setcdr (last headers)
158 (list (ews-parse-multipart/form
160 (substring pending last-index index)))))
161 ;; a boundary suffixed by "--" indicates the end of the headers
162 (when (and (> (length pending) (+ tmp 2))
163 (string= (substring pending tmp (+ tmp 2)) "--"))
164 (throw 'finished-parsing-headers t)))
165 ;; Standard header parsing.
167 (let ((this (ews-parse (substring pending last-index index))))
168 (if (and (caar this) (eql (caar this) :CONTENT-TYPE))
169 (cl-destructuring-bind (type &rest data)
170 (mail-header-parse-content-type (cdar this))
171 (unless (string= type "multipart/form-data")
172 (error "TODO: handle content type %S" type))
173 (when (assoc 'boundary data)
174 (setq boundary (cdr (assoc 'boundary data)))
175 (setq delimiter (concat "\r\n--" boundary))))
176 (setcdr (last headers) this)))))
177 (setq last-index tmp)))
178 (setq leftover (ews-trim (substring pending last-index)))
181 (defun ews-call-handler (proc request handler)
182 (catch 'matched-handler
183 (mapc (lambda (handler)
184 (let ((match (car handler))
185 (function (cdr handler)))
186 (when (or (and (consp match)
187 (assoc (car match) request)
188 (string-match (cdr match)
189 (cdr (assoc (car match) request))))
190 (and (functionp match) (funcall match request)))
191 (throw 'matched-handler (funcall function proc request)))))
193 (error "[ews] no handler matched request:%S" request)))
196 ;;; Convenience functions to write responses
197 (defun ews-response-header (proc code &rest header)
198 "Send the headers for an HTTP response to PROC.
199 Currently CODE should be an HTTP status code, see
200 `ews-status-codes' for a list of known codes."
203 (format "HTTP/1.1 %d %s" code (cdr (assoc code ews-status-codes)))
204 (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) header))))
205 (setcdr (last headers) (list "" ""))
206 (process-send-string proc (mapconcat #'identity headers "\r\n"))))
208 (provide 'emacs-web-server)
209 ;;; emacs-web-server.el ends here