В прошлой статье мы начали разработку нашего веб-сервера. Продолжим c файлом util.lisp. В этом пакете будут находится все наши вспомогательные функции для обработки запросов. Для начала обьявим переменную *line*, она нам понадобится в дальнейшем.
Также нам понадобится функция которая будет считывать байты со стрима в utf-8 и преобразовывать их в строку с помощью функции trivial-utf-8:utf-8-bytes-to-string.
Наш веб-сервер будет уметь обрабатывать только GET запросы. Если кому-то интересно, то он может написать обработку POST запросов, но пока мы всё-таки ограничимся GET запросами. Типичный HTTP GET запрос выглядит примерно вот так
Для POST запросов мы ничего делать не собираемся так что напишем простую функцию
Для GET запроса мы должны получить путь запрашиваемого ресурса и все остальные header-ы
Начнём с parse-path
Прежде чем мы начнём парсить параметры нам понадобится ещё одна вспомогательная функция для преобразования символов используемых в параметрах в 16-тиричной форме в их непосредственные значения.
Теперь осталось превратить наши параметры в alist.
Наш parse-params готов, осталось написать функцию parse-headers, здесь всё намного проще
На этом parse-get-header готов и должен возвращать структуру типа
Для удобства работы с данной структурой добавим две вспомогательные функции
Теперь когда у нас есть request мы можем послать клиенту ответ. Типичный ответ выглядит примерно так
Напишем пару вспомогательных функций которые будут помогать нам в работе с ответами
Теперь осталось написать функцию которая будет выдавать нам файлы из директории web
Теперь напишем вторую функцию html-template, которая будет брать любой текстовый файл из директории web и заменять значения типа ${name} на значения указанные в alist списке с такими же названиями. Своего рода примитивный template engine
На этом наш util.lisp почти готов, осталось только написать функции для логов. Начнём с конфигурации cl-log в файле log.lisp
Теперь добавим в util.lisp функцию для логирования которая будет логировать сообщения в отдельном потоке при этом не чаще чем 1 раз в секунду. Что позволит снять нагрузку от логирования напрямую
Для этого мы будем использовать вспомогательные функции логирования
Осталось добавить в handler.lisp process-request и испробовать наши функции
Создайте в папке web файл index.html
Запустите веб-сервер с помощью (myweb:start-http «localhost» 8080) и зайдите броузером на localhost:8080
Спасибо за внимание
(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¶m1=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
Спасибо за внимание