Write a web server in Common Lisp part two

last article we started development of our web servers. Continue c file util.lisp. This package is all of our helper functions to handle requests. For a start, declare a variable *line*, we'll need it in the future.

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

Also, we need a function which will read the bytes from stream in utf-8 and convert them to a string by using the trivial-utf-8:utf-8-bytes-to-string.
the

(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)))

All we do is we just read bytes until we get a byte with a value of end and convert the resulting byte array to a string. This function can be written differently (more efficiently), but I did it here is such a variant. If you have good ideas I'd love to see them in the comments. Declare another function

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

It will help us to write the answers to the client in the same format (utf-8)

Our web server will be able to handle only GET requests. If anyone is interested, he can write handling POST requests, but we still restrict GET requests. A typical HTTP GET request looks like this
the

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

First thing we do is find out what type of request we received on the web server.
the

(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)))))

For POST requests there is nothing we are not going to do so let's write a simple function
the

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

For GET request, we must receive the path of the requested resource and all other header-s
the

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

For this we will use the function parse-path and parse-headers

Let's start with parse-path
the

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

As you can see here we separate the path from the parameters and parsim parameters separately function parse-params

Before we start to parse the parameters, we will need another auxiliary function to convert the characters used in the parameters in a 16-lirichnoj form in their immediate value.
the

(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)))

This function can be called http char-decode

Now we have to turn our settings in alist.
the

(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)))

As you can see we use the decode-params, which in turn again calls the recursive parse-params pre-outparcel parameter name=value with decode-kv. In the end using the auxiliary function decode-param, which separates the http special characters and converts them using the http char is already returning the converted data

Our parse-params is ready, it remains to write a function parse-headers much easier
the

(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)))

(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)))))))

We first take a string (read-utf-8-string stream 10), where 10 is the value of \n in ASCII and if it is greater than two characters, parsim it with parse-header. The result is alist of all header-ov.

parse-get-header is ready and must return a structure of type
the

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

For convenience, this structure will add two helper functions
the

(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)))

Now when we have a request we can send a response to the client. A typical response looks like this
the

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

Write a few helper functions which will help us with answers.
the

(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))

As you can see here all too easy.

Now we have to write a function that will give us the files in the directory web
the

(defun file-response (type filename 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)
)))

This will allow our web server to return such files as images and html pages. We also returned header Last-Modified with date of last modification of the file. If we receive a request for the same file a second time with header-ω if-modified-since, we will smartem date with the latest date modified of the file. If the date is not changed, this means that the web browser has the latest version of the file in its cache so we just return code 304 Not Modified

Now write a second function of the html template that will take any text file in the directory web and replace the values like ${name} with the values specified in alist the list with the same names. Sort of a primitive template engine
the

(defun html-template (filename stream type params request)
(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)
)))

Our util.lisp is almost ready, it remains only to write the function for logs. Let's start with the configuration cl-log in log.lisp
the

(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)))

Here all is standard, the only thing that we changed is format-message where we just print the date in the formatted form.

Now add in util.lisp function for logging which will log messages in a separate thread not more frequently than 1 time per second. That will relieve the pressure from logging directly
the

(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*))

))
(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")

For this we will use a helper function logging
the

(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*))
)))

It remains to add in handler.lisp process-request and experience our
the

(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" request stream nil)
)))

Create the folder web index.html
the

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

And file name.html
the

<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>

And don't forget to put beautiful logo.jpg

Start the web server using (myweb:start-http "localhost" 8080) and go to browser on localhost:8080

Thank you for your attention

Article based on information from habrahabr.ru