Пишем веб-сервер на Common Lisp часть вторая

В прошлой статье мы начали разработку нашего веб-сервера. Продолжим c файлом util.lisp. В этом пакете будут находится все наши вспомогательные функции для обработки запросов. Для начала обьявим переменную *line*, она нам понадобится в дальнейшем.

(defvar *new-line* (concatenate 'string (string #\Return) (string #\Newline)))

Также нам понадобится функция которая будет считывать байты со стрима в utf-8 и преобразовывать их в строку с помощью функции trivial-utf-8:utf-8-bytes-to-string.

(defun read-utf-8-string (stream &optional (end 0))
  (let ((byte -1)
	(buffer (make-array 1 :fill-pointer 0 :adjustable t)))
    (handler-case 
	(loop do
	     (setq byte (read-byte stream))
	     (if (/= byte end) (vector-push-extend byte buffer))
	   while (/= byte end))
      (end-of-file ()))
    (trivial-utf-8:utf-8-bytes-to-string buffer)))

Всё что мы делаем это просто считываем байты до того как нам попадётся байт со значением end и преобразуем полученный массив байтов в строку. Эту функцию можно написать по-другому (более эффективно), но у меня получился вот такой вот вариант. Если у вас есть хорошие идеи буду рад увидеть их в комментариях. Объявим ещё одну функцию

(defun response-write (text stream)
  (trivial-utf-8:write-utf-8-bytes text stream))

Она нам поможет писать ответы клиенту в том же формате (utf-8)

Наш веб-сервер будет уметь обрабатывать только GET запросы. Если кому-то интересно, то он может написать обработку POST запросов, но пока мы всё-таки ограничимся GET запросами. Типичный HTTP GET запрос выглядит примерно вот так

GET /path/to/a/resource?param1=paramvalue1&param1=paramvalu2 HTTP/1.1 \r\n
HeaderName: HeaderValue \r\n
....
HeaderName: HeaderValue \r\n
\r\n

Первое что мы делаем это узнаём какого типа запрос нам пришёл на веб-сервер.

(defun parse-request (stream)
  (let ((header (read-utf-8-string stream 10)))
    (if (eq (length header) 0)
	'()
	(if (equal (subseq header 0 4) "POST")
	    (parse-post-header header stream)
	    (parse-get-header header stream)))))

Для POST запросов мы ничего делать не собираемся так что напишем простую функцию

(defun parse-post-header (header stream)
  (cons "POST" nil))

Для GET запроса мы должны получить путь запрашиваемого ресурса и все остальные header-ы

(defun parse-get-header (header stream)
  (cons "GET" 
	(cons (parse-path (subseq header (position #\/ header) (position #\Space header :from-end t)))
	      (parse-headers stream))))

Для этого мы будем использовать функции parse-path и parse-headers

Начнём с parse-path

(defun parse-path (path)
  (if (position #\? path)
      (cons (subseq path 0 (position #\? path)) (parse-params (subseq path (1+ (position #\? path)))))
      (cons path nil)))

Как видите здесь мы отделяем путь от параметров и парсим параметры отдельно функцией parse-params

Прежде чем мы начнём парсить параметры нам понадобится ещё одна вспомогательная функция для преобразования символов используемых в параметрах в 16-тиричной форме в их непосредственные значения.

(defun http-char (c1 c2 &optional (default #\Space))
  (let ((code (parse-integer (coerce (list c1 c2) 'string) :radix 16 :junk-allowed t)))
    (if code
	(code-char code)
	default)))

Эту функцию можно назвать http-char-decode

Теперь осталось превратить наши параметры в alist.

(defun parse-params (s)
  (let ((params (decode-params s)))
    (remove-duplicates params :test (lambda (x1 x2) (equal (car x1) (car x2))) :from-end nil)))

(defun decode-params (s)
  (let ((p1 (position #\& s)))
    (if p1 (cons (decode-kv (subseq s 0 p1)) (parse-params (subseq s (1+ p1))))
	(list (decode-kv s)))))

(defun decode-kv (s)
  (let ((p1 (position #\= s)))
    (if p1 (cons (decode-param (subseq s 0 p1)) (decode-param (subseq s (1+ p1))))
	     (cons (decode-param s) nil))))

(defun decode-param (s)
  (labels ((f (1st)
	     (when 1st
	       (case (car 1st)
		 (#\% (cons (http-char (cadr 1st) (caddr 1st))
			    (f (cdddr 1st))))
		 (#\+ (cons #\Space (f (cdr 1st))))
		 (otherwise (cons (car 1st) (f (cdr 1st))))))))
    (coerce (f (coerce s 'list)) 'string)))

Как видите для этого мы используем decode-params, которая в свою очередь опять вызывает рекурсивно parse-params предварительно отпарсив параметр name=value с помощью decode-kv. В конце используеться вспомогательную функцию decode-param, которая отделяет специальные http символы и преобразует их с помощью http-char возвращая уже преобразованные данные

Наш parse-params готов, осталось написать функцию parse-headers, здесь всё намного проще

(defun parse-headers (stream)
  (let ((headers nil)
	(header nil))
    (loop do
	 (setq header (read-utf-8-string stream 10))
	 (if (> (length header) 2) (setq headers (cons (parse-header header) headers)))
	 while (> (length header) 2))
    (reverse headers)))

(defun parse-header (header)
  (let ((pos (position #\: header)))
    (if pos (cons (string-downcase (subseq header 0 pos)) (string-trim (concatenate 'string (string #\Space) (string #\Return)) (subseq header (1+ pos)))))))

Мы сначала берём строку с помощью (read-utf-8-string stream 10), где 10 это значение \n в ASCII и если она больше чем два символа, парсим её с помощью parse-header. В результате получаем alist всех header-ов.

На этом parse-get-header готов и должен возвращать структуру типа

'("GET" ("path/to/file" (("param1" . "value1") ("param2" . "value2"))) (("header1" . "value1") ("header2" . "value2")))

Для удобства работы с данной структурой добавим две вспомогательные функции

(defun get-param (name request)
  (cdr (assoc name (cdadr request) :test #'equal)))

(defun get-header (name request)
  (cdr (assoc (string-downcase name) (cddr request) :test #'equal)))

Теперь когда у нас есть request мы можем послать клиенту ответ. Типичный ответ выглядит примерно так

HTTP/1.1 200 OK
HeaderName: HeaderValue \r\n
....
HeaderName: HeaderValue \r\n
\r\n
Data

Напишем пару вспомогательных функций которые будут помогать нам в работе с ответами

(defun http-response (code headers stream)
  (response-write (concatenate 'string "HTTP/1.1 " code *new-line*)  stream)
  (mapcar (lambda (header)
	    (response-write 
	     (concatenate 'string (car header) ": " (cdr header) *new-line*) stream)) headers)
  (response-write *new-line* stream))

(defun http-404-not-found (message stream)
  (http-response "404 Not Found" nil stream)
  (response-write message stream))

Как видите здесь всё тоже просто.

Теперь осталось написать функцию которая будет выдавать нам файлы из директории web

(defun file-response (filename type request stream)
  (handler-case
      (with-open-file (in (concatenate 'string "web/" filename) :element-type '(unsigned-byte 8))
	(if (equal (get-header "if-modified-since" request) (format-timestring nil (universal-to-timestamp (file-write-date in)) :format +asctime-format+))
	    (http-response "304 Not Modified" nil stream)
	(progn 
	  (http-response "200 OK" 
			 (cons
			  (cons "Last-Modified" (format-timestring nil (universal-to-timestamp (file-write-date in)) :format +asctime-format+))
			  (cons (cons "Content-Type" type) nil))
			 stream)
	  (let ((buf (make-array 4096 :element-type (stream-element-type in))))
	    (loop for pos = (read-sequence buf in)
	       while (plusp pos)
	       do (write-sequence buf stream :end pos)))	 
	)))
    (file-error () 
      (http-404-not-found "404 File Not Found" stream)
      )))

Это позволит нашему веб-серверу возвращать такие файлы как изображения и html страницы. При этом мы также возвращаем header Last-Modified с датой последней модификации файла. Если у нас придёт запрос на этот же файл во второй раз с header-ом if-modified-since, то мы смеряем дату с последней датой модификации файла. Если дата не изменилась это означает что веб броузер имеет самую последнюю версию файла в своём кэше поэтому мы просто возвращаем код 304 Not Modified

Теперь напишем вторую функцию html-template, которая будет брать любой текстовый файл из директории web и заменять значения типа ${name} на значения указанные в alist списке с такими же названиями. Своего рода примитивный template engine

(defun html-template (filename type params request stream)
  (handler-case
      (with-open-file (in (concatenate 'string "web/" filename) :element-type '(unsigned-byte 8))
	(loop for line = (read-utf-8-string in 10)
	   while (and line (> (length line) 0))  
	   do (progn
		(mapcar (lambda (i)
			  (let* ((key (concatenate 'string "${" (car i) "}")))
			    (loop for pos = (search key line)
				 while pos
			       do 
				 (setq line 
				       (concatenate 'string 
						    (subseq line 0 pos) (cdr i) 
						    (subseq line (+ pos (length key)))))
				 )
			  )) params)
		(response-write line stream)
		(response-write (string #\Return) stream))
	   )
	)
    (file-error () 
      (http-404-not-found "404 File Not Found" stream)
      )))

На этом наш util.lisp почти готов, осталось только написать функции для логов. Начнём с конфигурации cl-log в файле log.lisp

(setf (log-manager)
          (make-instance 'log-manager :message-class 'formatted-message))

(start-messenger 'text-file-messenger :filename "log/web.log")

(defmethod format-message ((self formatted-message))
  (format nil "~a ~a ~?~&"
	  (local-time:format-timestring nil 
					(local-time:universal-to-timestamp 
					 (timestamp-universal-time (message-timestamp self))))
	  (message-category self)
	  (message-description self)
	  (message-arguments self)))

Здесь всё стандартно, единственное что мы поменяли это format-message где мы просто выводим дату в отформатированном виде.

Теперь добавим в util.lisp функцию для логирования которая будет логировать сообщения в отдельном потоке при этом не чаще чем 1 раз в секунду. Что позволит снять нагрузку от логирования напрямую

(defvar *log-queue-lock* (bt:make-lock))
(defvar *log-queue-cond* (bt:make-condition-variable))
(defvar *log-queue-cond-lock* (bt:make-lock))
(defvar *log-queue* nil)
(defvar *log-queue-time* (get-universal-time))

(defun log-worker ()
  (bt:with-lock-held (*log-queue-lock*)
    (progn 
      (mapcar (lambda (i) (if (cdr i) (cl-log:log-message (car i) (cdr i)))) (reverse *log-queue*))
      (setq *log-queue* nil)
      ))
  (bt:with-lock-held (*log-queue-cond-lock*)
    (bt:condition-wait *log-queue-cond* *log-queue-cond-lock*)
    )
  (log-worker))

(bt:make-thread #'log-worker :name "log-worker")

Для этого мы будем использовать вспомогательные функции логирования

(defun log-info (message)
  (bt:with-lock-held (*log-queue-lock*)
    (progn 
      (push (cons :info message) *log-queue*)
      (if (> (- (get-universal-time) *log-queue-time*) 0)
	  (bt:condition-notify *log-queue-cond*))
      )))

(defun log-warning (message)
  (bt:with-lock-held (*log-queue-lock*)
    (progn 
      (push (cons :warning message) *log-queue*)
      (if (> (- (get-universal-time) *log-queue-time*) 0)
	  (bt:condition-notify *log-queue-cond*))
      )))

(defun log-error (message)
  (bt:with-lock-held (*log-queue-lock*)
    (progn 
      (push (cons :error message) *log-queue*)
      (if (> (- (get-universal-time) *log-queue-time*) 0)
	  (bt:condition-notify *log-queue-cond*))
      )))

Осталось добавить в handler.lisp process-request и испробовать наши функции

(defun process-request (request stream)
  (let ((path (caadr request)))
    (cond
      ((equal path "/logo.jpg") (myweb.util:file-response "logo.jpg" "image/jpeg" request stream))
      (t 
       (process-index request stream)))))

(defun process-index (request stream)
  (let ((name (myweb.util:get-param "name" request)))
    (if (and name (> (length name) 0))
	(myweb.util:html-template "index.html" "text/html;encoding=UTF-8" `(("name" . ,name)) request stream)
	(myweb.util:html-template "name.html" "text/html;encoding=UTF-8" nil request stream)
      )))

Создайте в папке web файл index.html

<html>
<head>
<title>myweb</title>
</head>
<body>
<image src="logo.jpg">
<h1>Hello ${name}</h1>
</body>
</html>

И файл name.html

<html>
<head>
<title>myweb</title>
</head>
<body>
<image src="logo.jpg">
<h2>Hello stranger. What's your name?</h2>
<form action="/" method="GET">
Name: <input type="text" name="name">
<input type="submit" value="Submit">
</form>
</body>
</html>

И не забудьте положить туда красивое logo.jpg

Запустите веб-сервер с помощью (myweb:start-http «localhost» 8080) и зайдите броузером на localhost:8080

Спасибо за внимание