Writing a Common Lisp Web Server Part Two

    In the last article, we started developing our web server. Continue with the util.lisp file. This package will contain all our auxiliary functions for processing requests. First, declare the variable * line *, we will need it in the future.
    (defvar *new-line* (concatenate 'string (string #\Return) (string #\Newline)))
    

    We also need a function that will read bytes from the stream in utf-8 and convert them to a string using the trivial-utf-8 function : utf-8-bytes-to-string .
    (defun read-utf-8-string (stream&optional (end0))
      (let ((byte-1)
    	(buffer (make-array1:fill-pointer0:adjustablet)))
        (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 just read the bytes before we get the byte with the value end and convert the resulting array of bytes into a string. This function can be written in another way (more efficiently), but I got such an option here. If you have any good ideas, I will be glad to see them in the comments. Declare another function
    (defun response-write (text stream)
      (trivial-utf-8:write-utf-8-bytes text stream))
    
    It will help us to write answers to the client in the same format (utf-8).

    Our web server will be able to process only GET requests. If anyone is interested, then he can write the processing of POST requests, but for now we will limit ourselves to GET requests. A typical HTTP GET request looks something like this
    GET /path/to/a/resource?param1=paramvalue1¶m1=paramvalu2 HTTP/1.1 \r\n
    HeaderName: HeaderValue \r\n
    ....
    HeaderName: HeaderValue \r\n\r\n
    The first thing we do is find out what type of request we received on the web server.
    (defun parse-request (stream)
      (let ((header (read-utf-8-string stream 10)))
        (if (eq (length header) 0)
    	'()
    	(if (equal (subseq header 04) "POST")
    	    (parse-post-header header stream)
    	    (parse-get-header header stream)))))
    

    We are not going to do anything for POST requests, so we will write a simple function
    (defun parse-post-header (header stream)
      (cons"POST"nil))
    

    For a GET request, we must get the path of the requested resource and all other headers
    (defun parse-get-header (header stream)
      (cons"GET" 
    	(cons (parse-path (subseq header (position #\/ header) (position #\Space header :from-endt)))
    	      (parse-headers stream))))
    
    To do this, we will use the parse-path and parse-headers functions.

    Let's start with 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)))
    
    As you can see here, we separate the path from the parameters and parse the parameters separately with the parse-params function.

    Before we begin to parse the parameters, we need another auxiliary function for converting the characters used in the parameters in hexadecimal to their immediate values.
    (defun http-char (c1 c2 &optional (default #\Space))
      (let ((code (parse-integer (coerce (list c1 c2) 'string) :radix16:junk-allowedt)))
        (if code
    	(code-char code)
    	default)))
    
    This function can be called http-char-decode

    Now it remains to turn our parameters into alist.
    (defun parse-params (s)
      (let ((params (decode-params s)))
        (remove-duplicates params :test (lambda (x1 x2) (equal (car x1) (car x2))) :from-endnil)))
    (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)
    	     (when1st
    	       (case (car1st)
    		 (#\% (cons (http-char (cadr1st) (caddr1st))
    			    (f (cdddr1st))))
    		 (#\+ (cons #\Space (f (cdr1st))))
    		 (otherwise (cons (car1st) (f (cdr1st))))))))
        (coerce (f (coerce s 'list)) 'string)))
    
    As you can see, we use decode-params for this , which in turn again calls parse-params recursively after pre-parsing the name = value parameter with decode-kv . In the end, we use the decode-param helper function , which separates special http characters and converts them using http-char returning already converted data

    Our parse-params is ready, it remains to write the parse-headers function , everything is much simpler here
    (defun parse-headers (stream)
      (let ((headersnil)
    	(headernil))
        (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)))))))
    
    We first take the string using (read-utf-8-string stream 10), where 10 is the value \ n in ASCII and if it is more than two characters, parse it with parse-header. As a result, we get alist of all headers.

    On this, parse-get-header is ready and should return a structure of type
    '("GET" ("path/to/file" (("param1" . "value1") ("param2" . "value2"))) (("header1" . "value1") ("header2" . "value2")))
    

    For the convenience of working with this structure, we add two auxiliary functions
    (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 that we have a request, we can send a response to the client. A typical answer looks something like this
    HTTP/1.1 200 OK
    HeaderName: HeaderValue \r\n
    ....
    HeaderName: HeaderValue \r\n\r\n
    Data
    

    We will write a couple of auxiliary functions that will help us in working with answers
    (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, everything is also simple.

    Now it remains to write a function that will give us files from the web directory
    (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-timestringnil (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-timestringnil (universal-to-timestamp (file-write-date in)) :format +asctime-format+))
    			  (cons (cons"Content-Type" type) nil))
    			 stream)
    	  (let ((buf (make-array4096: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 files such as images and html pages. At the same time, we also return the Last-Modified header with the date of the last file modification. If we get a request for the same file for the second time with header if-modified-since, then we’ll freeze the date with the last modification date of the file. If the date has not changed, this means that the web browser has the latest version of the file in its cache so we just return the 304 Not Modified code

    Now we write a second html-template function that will take any text file from the web directory and replace the values ​​with the type $ {name} to the values ​​indicated in the alist list with the same names. A kind of primitive 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)
          )))
    

    On this our util.lisp is almost ready, it remains only to write functions for the logs. Let's start with the cl-log configuration in the log.lisp file
    (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))
      (formatnil"~a ~a ~?~&"
    	  (local-time:format-timestringnil 
    					(local-time:universal-to-timestamp 
    					 (timestamp-universal-time (message-timestamp self))))
    	  (message-category self)
    	  (message-description self)
    	  (message-arguments self)))
    
    Everything is standard here, the only thing we have changed is format-message where we simply display the date in a formatted form.

    Now let's add a function for logging to util.lisp that will log messages in a separate thread at the same time no more than 1 time per second. What will allow to take off loading from logging directly
    (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")
    

    For this we will use auxiliary logging functions
    (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 process-request to handler.lisp and try our functions
    (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)
          )))
    

    Create an index.html file in the web folder
    <html><head><title>myweb</title></head><body><imagesrc="logo.jpg"><h1>Hello ${name}</h1></body></html>
    And the name.html file
    <html><head><title>myweb</title></head><body><imagesrc="logo.jpg"><h2>Hello stranger. What's your name?</h2><formaction="/"method="GET">
    Name: <inputtype="text"name="name"><inputtype="submit"value="Submit"></form></body></html>
    And do not forget to put a beautiful logo.jpg in there.

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

    Thank you for your attention

    Also popular now: