Пишем веб-сервер на 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¶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

    Спасибо за внимание
    Поделиться публикацией

    Комментарии 6

      +1
      Больше серверов, хороших и разных :)
        0
        Пожалуйста сделайте zip файл.
          0
          zip файл чего?
            +1
            Исходников видимо, чтобы сразу собрать и загрузить на продакшен сервер.
              +4
              Так исходники же можно гитом взять вот отсюда
                0
                Простите. Было не очевидно. И вправду ссылка была в первом посте. Проглядел.

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

        Самое читаемое