Автоматическая генерация ссылок в RESTAS

Одной из типовых проблем веб-разработки является генерация ссылок. В некоторых простых случаях на неё можно просто закрыть глаза и создавать ссылки "вручную". Например, недавно rigidus опубликовал на хабре статью, в которой рассказал про создание простого сайта на Common Lisp (с использование RESTAS). В данном примере для генерации главного меню используется такой код:

(defun menu ()
  (list (list :link "/" :title "Главная")
        (list :link "/about" :title "About")
        (list :link "/articles" :title "Статьи")
        (list :link "/resourses" :title "Ресурсы")
        (list :link "/contacts" :title "Контакты")))

Т.е. ссылки жёстко задаются в теле программы. Поскольку здесь их всего 5 и они очень простые, то в данном случае это не создаёт больших проблем.

Однако, по мере роста приложения, а также в процессе изменения его структуры, проблема сохранения актуальности ссылок приобретает серьёзный характер.

Самый лучший способ решения данной проблемы использовать автоматическую генерацию ссылок. В RESTAS для этого есть специальная поддержка на базе функции restas:genurl. Например, с использованием данной функции вышеприведённый код можно было бы переписать следующим образом:

(defparameter *mainmenu*
  '((main . "Главная")
    (about . "About")
    (articles . "Статьи")
    (resources . "Ресурсы")
    (contacts . "Контакты")))

(defun menu ()
  (iter (for (route . title) in *mainmenu*)
        (collect (list :link (restas:genurl route)
                       :title title))))

Здесь для генерации ссылок используется символ, связанный с конкретным маршрутом, а получающиеся ссылки будут учитывать базовый url, по которому подключается разрабатываемый модуль.

Это очень простая ситуация, которая решается совершенно тривиальным образом. На сайте lisper.ru имеет место более сложный случай. Исходный код данного ресурса разбит на несколько совершенно независимых пакетов, которые объединяются в один сайт на основе механизма модулей. Простое использование restas:genurl здесь не подходит, поскольку маршруты, на которые ссылается главное меню, находятся в разных модулях. Для определения состава главного меню используется такое объявление:

(defparameter *mainmenu* `(("Главная" nil main)
                           ("Статьи" rulisp-articles restas.wiki:main-wiki-page)
                           ("Планета" rulisp-planet restas.planet:planet-main)
                           ("Форум" rulisp-forum restas.forum:list-forums)
                           ("Сервисы" nil tools-list)
                           ("Practical Common Lisp" rulisp-pcl rulisp.pcl:pcl-main)
                           ("Wiki" rulisp-wiki restas.wiki:main-wiki-page)
                           ("Файлы" rulisp-files restas.directory-publisher:route :path "")
                           ("Поиск" nil google-search)))

Здесь каждому элементу меню соответствует список, содержащий следующие элементы: заголовок, субмодуль (символ, который используется при вызове restas:mount-submodule), символ маршрута (указанный в restas:define-route) и возможно несколько ключевых параметров (параметров маршрута). А для непосредственной генерации ссылок используется такой код:

(in-package #:rulisp)

(restas:with-submodule (restas:find-upper-submodule #.*package*)
  (iter (for item in *mainmenu*)
        (collect (list :href (apply #'restas:genurl-submodule
                                    (second item)
                                    (if (cdddr item)
                                        (cddr item)
                                        (last item)))
                       :name (first item))))) 

Наиболее интересной в данном коде является строка

(restas:with-submodule (restas:find-upper-submodule #.*package*)

Дело в том, что генерация меню происходит каждый раз при генерации HTML-страницы для всех маршрутов, которые находятся в разных модулях и имеют различный контекст выполнения, а параметр *mainmenu* составлен с точки зрения самого верхнего модуля :rulisp, который используется для запуска приложения с помощью start.

Структура субмодулей в RESTAS образует иерархию и restas:find-upper-submodule позволяет найти нужный модуль выше по дереву, а макрос restas:with-submodule выполнить код в контексте найденного модуля. Таким образом, генерация ссылок работает всегда одинаково, не зависимо от контекста выполнения этого кода.

restas:find-upper-submodule и restas:with-submodule я добавил только сегодня, так что они пока есть только в git-версии RESTAS.

Колличество процессоров

Если вам вдруг потребуется узнать количество процессоров в коде на Common Lisp, то сделать это с помощью iolib можно так:

(iolib.syscalls:sysconf iolib.syscalls:sc-nprocessors-onln)

10 тысяч запросов в секунду

Накидал очень простой (100 строк кода) прототип асинхронного веб-сервера на базе iolib. Он умеет принимать GET-запрос и не обращая на него внимание отдавать одну и ту же страницу. Практической пользы от него никакой, но для исследования вопроса вполне сгодится. Так вот, планка в 10 000 запросов в секунду (тестировал через ab) на моей машине была уверенно взята без каких-либо оптимизаций - временами скорость доходила до 11 000 запросов в секунду. Код не полностью корректен, но от него это и не требуется. Всё обработка ведётся в одном потоке. Собственно, код:

(asdf:operate 'asdf:load-op '#:iolib)
(asdf:operate 'asdf:load-op '#:iterate)

(defpackage #:http.test
  (:use #:cl #:iter)
  (:export #:start #:stop))

(in-package #:http.test)

(defparameter *event-base* nil)

(defparameter *reply*
  (let ((endl #.(babel:octets-to-string (coerce #(13 10) '(vector (unsigned-byte 8)))))
        (content  "<html>
  <head>
    <title>Hello world</title>
  </head>
  <body>
    <h1>Hello world</h1>
  </body>
</html>"))
    (babel:string-to-octets 
     (with-output-to-string (out)
       (write-string "HTTP/1.0 200 OK" out)
       (write-string endl out)
       (format out "Content-Length: ~A" (length content))
       (write-string endl out)
       (write-string "Content-Type: text/html" out)
       (write-string endl out)
       (write-string endl out)
       (write-string content out))
     :encoding :latin1)))

(defvar *bucket-pool* nil)

(defun get-bucket ()
  (or (pop *bucket-pool*)
      (make-array 4096 :element-type '(unsigned-byte 8))))

(defun free-bucket (bucket)
  (push bucket *bucket-pool*))

(defun read-http-headers (socket callback)
  (let ((headers (get-bucket))
        (size 0))
    (flet ((read-handler (fd event errorp)
             (declare (ignore event errorp fd))
             (multiple-value-bind (buffer count) (iolib.sockets:receive-from socket :buffer headers)
               (declare (ignore buffer))
               (incf size count))

             (when (and (> size 4)
                        (equal '(13 10 13 10)
                               (coerce (subseq headers (- size 4) size) 'list)))
               (iolib.multiplex:remove-fd-handlers *event-base*
                                                   (iolib.sockets:socket-os-fd socket)
                                                   :read t)
               (free-bucket headers)
               (funcall callback))))
      (iolib.multiplex:set-io-handler *event-base*
                                      (iolib.sockets:socket-os-fd socket)
                                      :read #'read-handler))))

(defun send-http-reply (socket data callback)
  (let ((curpos 0)
        (total-length (length data)))
    (flet ((write-handler (fd event errorp)
             (declare (ignore fd event errorp))
             (cond
               ((= curpos total-length)
                (iolib.multiplex:remove-fd-handlers *event-base*
                                                    (iolib.sockets:socket-os-fd socket)
                                                    :write t)
                (funcall callback))
               (t (incf curpos
                        (iolib.sockets:send-to socket data :start curpos))))))
      (iolib.multiplex:set-io-handler *event-base*
                                      (iolib.sockets:socket-os-fd socket)
                                      :write #'write-handler))))

(defun accept-connection (passive-socket)
  (let ((active-socket (iolib.sockets:accept-connection passive-socket)))
    (read-http-headers active-socket
                       (lambda ()
                         (send-http-reply active-socket
                                          *reply*                                            
                                          (lambda ()
                                            (close active-socket)))))))

(defun start (&optional (port 8080))
  (setf *event-base* (make-instance 'iolib.multiplex:event-base))
  (flet ((impl ()
           (iolib.sockets:with-open-socket (acceptor :connect :passive
                                                     :address-family :internet
                                                     :type :stream
                                                     :external-format '(:utf-8 :eol-style :crlf)
                                                     :ipv6 nil)
             (iolib.sockets:bind-address acceptor
                                         iolib.sockets:+ipv4-unspecified+
                                         :port port
                                         :reuse-addr t)
             (iolib.sockets:listen-on acceptor :backlog 5)

             (flet ((accept (fd event errorp)
                      (declare (ignore fd event errorp))
                      (accept-connection acceptor)))
               (iolib.multiplex:set-io-handler *event-base*
                                               (iolib.sockets:socket-os-fd acceptor)
                                               :read #'accept))
             
             (iolib.multiplex:event-dispatch *event-base*)
             (close *event-base*))))
    (bordeaux-threads:make-thread #'impl
                                  :name "*http-server*")))
    
(defun stop ()
  (iolib.multiplex:exit-event-loop *event-base*))

Обработка PNG-изображений на Common Lisp

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

А вот с этим проблема, поскольку украденный мной набор png-файлов сделан только в чёрном исполнении. Сам я в дизайне полный ноль, всякими Gimp-ами владею очень слабо и вообще, как создаются подобные изображения понятия не имею: я пробовал создать такое просто кодом с помощью градиентов, закруглений и т.п., но так хорошо никак не получается.

И я решил просто по-пиксельно заменить все цвета оригинальных изображений на новые, которые будут вычисляться на основе базового цвета. В оригинальных файлах основным цветом является rgb(30, 30, 30), но для создания эффекта тени используется переход данного цвета в чёрный. Функция translate-color вычисляет новый цвет на основе базового и опирается на rgb(30, 30, 30) как на основу старого изображения:

(defun translate-color (orig base-color)
  (iter (for i in orig)
        (for j in base-color)
        (collect (min (max (+ i j -30) 0)
                      255))))

Для создания png-файлов есть известное и хорошее решение - ZPNG, а вот библиотеки для разбора png-файлов я не знал и кажется такая библиотека не освещалось широко где-либо, по крайней мере, я не видел. Однако, быстрый поиск в гугл сразу показал мне библиотеку png-read. Я опробовал её на нескольких примерах и кажется она "просто работает". Таким образом, я смог записать такой код по изменению цвета нужных мне изображений:

(defun make-other-png (orig dest base-color)
  (let* ((orig-png (png-read:read-png-file orig))
         (orig-image (png-read:image-data orig-png))
         (png (make-instance 'zpng:png
                             :color-type :truecolor-alpha
                             :width (png-read:width orig-png)
                             :height (png-read:height orig-png)))
         (image (zpng:data-array png)))
    (iter (for w from 0 below (png-read:width orig-png))
          (iter (for h from 0 below (png-read:height orig-png))
                (iter (for c in (translate-color (list (aref orig-image w h 0)
                                                       (aref orig-image w h 1)
                                                       (aref orig-image w h 2))
                                                 base-color))
                      (for i from 0)
                      (setf (aref image h w i) c))
                (setf (aref image h w 3)
                      (aref orig-image w h 3))))
    (zpng:write-png png dest)))

Функция make-other-png принимает путь к оригинальному файлу, путь для сохранения нового изображения и цвет, который должен являться базовым для нового изображения.

Опробовал данный код и остался очень доволен результатом. Вот что получается в результате вызова

(make-other-png "win_LB.png" "out.png" '(0 192 0))

Слева оригинальное изображение, а с права получившееся в результате преобразования.

P.S. Ebuild для png-read я добавил в свой форк gentoo-lisp-overlay.

Переделал свой форк cl-pdf

Форк cl-pdf я сделал довольно давно и тогда я ещё плохо ориентировался как в CL, так и в git, в итоге форк был оформлен очень топорно, без истории изменений. Сейчас дошли руки полностью его переделать используя git svn, так что в него попала полная история изменения. Все свои изменения также внёс одно за другим. Так что стало намного лучше и можно теперь нормально синхронизироваться с основным репозиторием, если там вдруг будут изменения, а они там бывают, хоть и реже чем раз в год.

От оригинальной версии мой форк отличается следующим:

• Почищен разный мусор, типа каких-то левых патчей для поддержки CMUCL, различных вариаций на тему zlib и т.п., которые предлагалось как-то загружать руками
• Для сжатия используется salza2 и только она.
• Поддерживается загрузка и использования ttf шрифтов с помощью zpb-ttf
• У функций draw-centered-text, draw-left-text и draw-right-text имеется дополнительный опциональный параметр max-height (параметр max-width уже был в оригинальной версии)
• Добавлена функция append-child-ouline, а также экспортируется функция outline-root

Вообще надо немного привести в порядок код для генерации PDF, который я использую на работе, а также код для генерации PDF-версии PCL, который используется на lisper.ru и в соответствии с этим также внести ряд небольших изменений.

Плюс, есть желание выкинуть из cl-pdf код для парсинга PNG-файлов и использовать для этого библиотеку png-read (которую я обнаружил на днях) и сделать возможным использование PNG-изображений с прозрачностью (сейчас мне приходиться насильственно добавлять к таким изображениям фон).

Мой форк: http://github.com/archimag/cl-pdf

Необычное использование restas-directory-publisher

Модуль restas-directory-publisher по начальной задумке предназначался для простой публикации директорий, содержащих статические файлы. Но в последнее время я использовал его сразу несколькими способами, которые я никак не ожидал в момент разработки и которые показались мне довольно любопытными. Так что решил немного об этом рассказать.

Сейчас у меня возникла необходимость показывать на странице пользователю диалог, в котором о мог бы выбрать файл, находящийся на файловой системе сервера. Немного погуглив нашёл несколько решений и примеров для jquery, которые показались мне просто ужасными и я решил, что сделать собственное решение будет значительно проще и быстрее. Как оказалось, делается оно почти тривиально.

Полученное мною решение состоит из трёх частей: шаблон cl-closure-template для генерации контента на стороне клиента, несколько строк кода на JavaScript для управления и серверная часть, которая возвращает информацию о файловой системе.

Модуль restas-directory-publisher умеет собирать информацию о файловой системе, но по умолчанию возвращаёт её в формате html, а мне для данной задачи нужно в формате JSON. Исправить этот недостаток можно так:

(defun encode-json (obj)
  (flet ((encode-json-list (list stream)
           (if (keywordp (car list))
               (json:encode-json-plist list stream)
               (json::encode-json-list-guessing-encoder list stream))))
    (let ((json::*json-list-encoder-fn* #'encode-json-list))
      (json:encode-json-to-string obj))))

(restas:mount-submodule -file-system- (#:restas.directory-publisher)
  (restas.directory-publisher:*baseurl* '("api"))
  (restas.directory-publisher:*directory* #P"/")
  (restas.directory-publisher:*autoindex* t)
  (restas.directory-publisher:*autoindex-template* #'encode-json))

Здесь производится настройка подключения субмодуля и с переменной restas.directory-publisher:*autoindex-template*, используемой для генерации контента, связывается функция #'encode-json (реализацию данной функции я уже приводил ранее).

Шаблон для генерации разметки:

{template directoryBrowse}
    <table summary="Directory Listing" cellpadding="0" cellspacing="0">
        <thead>
            <tr>
                <th class="n">Name</th>
                <th class="m">Last Modified</th>
                <th class="s">Size</th>
                <th class="t">Type</th></tr>
        </thead>

        <tbody>
            {if $parent}
                <tr>
                    <td class="n">
                        <span class="directory" href="{$parent}">Parent Directory</span>
                    </td>
                    <td class="m"> </td>
                    <td class="s">-  </td>
                    <td class="t">Directory</td>
                </tr>
            {/if}

            {foreach $path in $paths}
                <tr>
                    <td class="n">
                        <span class="{$path.type == 'Directory' ? 'directory' : 'file'}" href="{$path.href}">
                            {$path.name}
                        </span>
                        {nil}
                        {if $path.type == 'Directory'}/{/if}
                    </td>
                    <td class="m">{$path.lastModified}</td>
                    <td class="s">{$path.size ? $path.size : '-  ' |noAutoescape}</td>
                    <td class="t">{$path.type}</td>
                </tr>
            {/foreach}
        </tbody>
    </table>
{/template} 

Я лишь немного модифицировал шаблон, используемый в restas-directory-publisher

Управлящий код на JavaScript совсем прост:

$(document).ready( function () { browse("/api/"); } );

function browse (url) {
    function directoryClick (evt) {
        browse($(evt.currentTarget).attr("href"));
    }

    function fileClick (evt) {
        $("h1").html(decodeURI($(evt.currentTarget).attr("href")));
    }

    function handler (data) {
        $("#content").html(restas.jsBrowser.view.directoryBrowse(data));
        $("#content .directory").click(directoryClick);
        $("#content .file").click(fileClick);
    }

    $.getJSON(url, handler);
}

Я организовал этот код в виде отдельного законченного примера jsBrowser, который включил в состав restas-directory-publisher, посмотреть исходный код можно здесь

cl-mssql и FreeTDS-0.82

Обновил у себя FreeTDS до версии 0.82 и обнаружил проблемы с кодировками. Я использую cl-mssql для взаимодействия с 1С, данные там лежат в кодировке cp1251, а у меня в системе используется utf-8. Версия FreeTDS-0.62 кажется вообще никак не учитывала кодировки, поэтому в cl-mssql есть параметр соединения :external-format, который использовался для настройки переменной cffi:*default-foreign-encoding* - я устанавливал его в :cp1251 и спокойно работал. Версия FreeTDS-0.82 уже относится к этому не так просто и, вероятно, самостоятельно занимается перекодированием строк (а может как-то по другому взаимодействует с сервером, я не спец в этом вопросе). Теперь приходиться настраивать кодировку в /etc/freetds.conf:

[global]
    client charset = utf8

Кодировка, указанная в /etc/freetds.conf, должна совпадать с кодировкой, которая указывается в mssql:connect (по-умолчанию - :utf-8).