From 536f7a67bb3d634bb5445fa5b8d31e065e86bfb9 Mon Sep 17 00:00:00 2001 From: Hedin Date: Tue, 27 Mar 2018 09:26:22 +0300 Subject: [PATCH 1/7] Merge restas.simple-auth into rulisp --- rulisp.asd | 31 ++++- src/auth/cookie.lisp | 98 +++++++++++++++ src/auth/defmodule.lisp | 62 +++++++++ src/auth/sendmail.lisp | 32 +++++ src/auth/simple-auth.lisp | 207 +++++++++++++++++++++++++++++++ src/auth/storage.lisp | 177 ++++++++++++++++++++++++++ src/auth/templates/forgot.tmpl | 125 +++++++++++++++++++ src/auth/templates/login.tmpl | 38 ++++++ src/auth/templates/register.tmpl | 124 ++++++++++++++++++ src/packages.lisp | 11 ++ src/rulisp.lisp | 20 +-- src/storage.lisp | 18 +-- 12 files changed, 919 insertions(+), 24 deletions(-) create mode 100644 src/auth/cookie.lisp create mode 100644 src/auth/defmodule.lisp create mode 100644 src/auth/sendmail.lisp create mode 100644 src/auth/simple-auth.lisp create mode 100644 src/auth/storage.lisp create mode 100644 src/auth/templates/forgot.tmpl create mode 100644 src/auth/templates/login.tmpl create mode 100644 src/auth/templates/register.tmpl diff --git a/rulisp.asd b/rulisp.asd index e34dc71..98e9f0c 100644 --- a/rulisp.asd +++ b/rulisp.asd @@ -7,21 +7,42 @@ (defsystem rulisp :depends-on (#:restas - #:simple-date #:postmodern + #:ironclad + #:split-sequence + #:simple-date + #:postmodern #:zip - #:restas-simple-auth #:restas-planet #:restas-wiki - #:restas-colorize #:restas-directory-publisher #:restas-forum - #:xfactory #:cl-typesetting + #:restas-planet + #:restas-wiki + #:restas-colorize + #:restas-directory-publisher + #:restas-forum + #:xfactory + #:cl-typesetting #:wiki-parser) + :defsystem-depends-on (#:closure-template) :components ((:file "pref") (:module :src :components ((:file "packages") (:module "dokuwiki" :components ((:file "render-html")) :depends-on ("packages")) + (:module "auth" + :components ((:module "templates" + :components ((:closure-template "forgot") + (:closure-template "login") + (:closure-template "register"))) + (:file "defmodule" :depends-on ("templates")) + (:file "storage" :depends-on ("defmodule")) + (:file "cookie" :depends-on ("storage")) + (:file "sendmail" :depends-on ("defmodule")) + (:file "simple-auth" :depends-on ("cookie" "sendmail"))) + :depends-on ("packages")) (:file "storage" :depends-on ("packages")) (:file "pcl" :depends-on ("rulisp")) (:file "jscl" :depends-on ("rulisp")) - (:file "rulisp" :depends-on ("storage" "dokuwiki"))) + (:file "rulisp" :depends-on ("storage" + "dokuwiki" + "auth"))) :depends-on ("pref")))) diff --git a/src/auth/cookie.lisp b/src/auth/cookie.lisp new file mode 100644 index 0000000..ce3af60 --- /dev/null +++ b/src/auth/cookie.lisp @@ -0,0 +1,98 @@ +;;;; cookie.lisp +;;;; +;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.auth) + +;;;; set-auth-cookie + +(defun pack-auth-cookie (name password &key (version 1) date) + (format nil + "~A|~A|~A|~A" + version + name + password + (or date + (get-universal-time)))) + +(defun encrypt-auth-cookie (name password &key (version 1) date) + (let ((result (ironclad:ascii-string-to-byte-array (pack-auth-cookie name password :version version :date date)))) + (ironclad:encrypt-in-place *user-auth-cipher* + result) + (ironclad:byte-array-to-hex-string result))) + + + +(defun set-auth-cookie (name password &key (version 1)) + (hunchentoot:set-cookie *cookie-auth-name* + :value (encrypt-auth-cookie name password :version version) + :path "/" + :expires (+ (get-universal-time) (* 60 60 24 4)) + :http-only t)) + +;;;; get-auth-cookie + +(defun unpack-auth-cookie (str) + (split-sequence:split-sequence #\| str)) + +(defun hex-string-to-byte-array (string &key (start 0) (end nil)) + (declare (type string string)) + (let* ((end (or end (length string))) + (length (/ (- end start) 2)) + (key (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (*)) key)) + (flet ((char-to-digit (char) + (let ((x (position char "0123456789abcdef" :test #'char-equal))) + (or x (error "Invalid hex key ~A specified" string))))) + (loop for i from 0 + for j from start below end by 2 + do (setf (aref key i) + (+ (* (char-to-digit (char string j)) 16) + (char-to-digit (char string (1+ j))))) + finally (return key))))) + +(defun decrypt-auth-cookie (str) + (ignore-errors + (let ((result (hex-string-to-byte-array str))) + (ironclad:decrypt-in-place *user-auth-cipher* + result) + (unpack-auth-cookie (babel:octets-to-string result :encoding :utf-8))))) + +(defun get-auth-cookie () + (let ((cookie (hunchentoot:cookie-in *cookie-auth-name*))) + (if cookie + (decrypt-auth-cookie cookie)))) + +;;; compute-user-login-name + +;; (restas:define-memoized-function compute-user-login/impl (cipher) +;; (let ((auth-info (get-auth-cookie))) +;; (if auth-info +;; (check-user-password (second auth-info) +;; (third auth-info))))) + +(defun compute-user-login-name () + "Return user name for *request*." + (let ((auth-info (get-auth-cookie))) + (if auth-info + (check-user-password (second auth-info) + (third auth-info))))) + +;;(compute-user-login/impl *user-auth-cipher*)) + +;;;; run-login + +(defun run-login (login password-md5 &key (version 1) ) + "Set cookie for user name and password" + ;; (setf *bindings* + ;; (acons :user-login-name login *bindings*)) + (set-auth-cookie login password-md5 :version version)) + +;;;; run-logout + +(defun run-logout () + "Clear cookie with auth information" + (hunchentoot:set-cookie *cookie-auth-name*)) diff --git a/src/auth/defmodule.lisp b/src/auth/defmodule.lisp new file mode 100644 index 0000000..f86e2fe --- /dev/null +++ b/src/auth/defmodule.lisp @@ -0,0 +1,62 @@ +;;;; defplugin.lisp +;;;; +;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.auth) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; preferences +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *sendmail* + (find-if #'fad:file-exists-p + (list "/usr/bin/sendmail" + "/usr/sbin/sendmail"))) + +(defparameter *re-email-check* + "^[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?$") + +(defparameter *noreply-email* "noreply@example.com") + +(defparameter *cookie-auth-name* "userauth") + +(defparameter *cookie-cipher-key* (ironclad:ascii-string-to-byte-array "Specify the secure key")) + +(defvar *user-auth-cipher*) + +(defparameter *finalize-page* #'closure-template.standard:xhtml-strict-frame) + +(defparameter *host* "example.com") + +;; (defparameter *storage* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; initialization +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod restas:initialize-module-instance ((module (eql #.*package*)) context) + (restas:context-add-variable + context + '*user-auth-cipher* + (ironclad:make-cipher :blowfish + :mode :ecb + :key (restas:context-symbol-value context + '*cookie-cipher-key*)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; md5 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun calc-md5-sum (val) + "Calc sha1 sum of the val (string)" + (ironclad:byte-array-to-hex-string + (ironclad:digest-sequence :md5 + (babel:string-to-octets val :encoding :utf-8)))) + +(defun calc-sha1-sum (val) + "Calc sha1 sum of the val (string)" + (ironclad:byte-array-to-hex-string + (ironclad:digest-sequence :sha1 + (babel:string-to-octets val :encoding :utf-8)))) diff --git a/src/auth/sendmail.lisp b/src/auth/sendmail.lisp new file mode 100644 index 0000000..7fc4e1e --- /dev/null +++ b/src/auth/sendmail.lisp @@ -0,0 +1,32 @@ +;;;; sendmail.lisp +;;;; +;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.auth) + +(defun prepare-subject (subject &optional (external-format :utf-8)) + (format nil + "=?~A?B?~A?=" + external-format + (base64:string-to-base64-string + (coerce (loop for code across (babel:string-to-octets subject + :encoding external-format) + collect (code-char code)) + 'string)))) + +(defun send-mail (to content) + #+sbcl(let* ((sendmail-process (sb-ext:run-program *sendmail* + to + :input :stream + :output nil + :error nil + :wait nil)) + (sendmail (sb-ext:process-input sendmail-process))) + (unwind-protect + (write-string content sendmail) + (close sendmail) + (sb-ext:process-wait sendmail-process) + (sb-ext:process-close sendmail-process)))) diff --git a/src/auth/simple-auth.lisp b/src/auth/simple-auth.lisp new file mode 100644 index 0000000..fc837bb --- /dev/null +++ b/src/auth/simple-auth.lisp @@ -0,0 +1,207 @@ +;;;; simple-auth.lisp +;;;; +;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.auth) + +(defun finalize-page (content title) + (funcall *finalize-page* + (list :title title :body content))) + +(defun logged-on-p () + (compute-user-login-name)) + +(defun not-logged-on-p () + (not (logged-on-p))) + +(defun password-cache (password) + (calc-md5-sum password)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; login +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route login ("login") + (finalize-page (rulisp.auth.view:login `(:forgot-href ,(restas:genurl 'forgot))) + "Вход")) + +(restas:define-route login/post ("login" :method :post) + (:requirement #'not-logged-on-p) + + (let ((name (hunchentoot:post-parameter "name")) + (password-md5 (password-cache (hunchentoot:post-parameter "password"))) + (done (hunchentoot:get-parameter "done"))) + (if (check-user-password name password-md5) + (progn + (run-login name password-md5) + (restas:redirect (if done + done + "/"))) + (restas:redirect 'login)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; logout +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route logout ("logout") + (:requirement #'logged-on-p) + (run-logout) + (restas:redirect (or (hunchentoot:header-in :referer hunchentoot:*request*) + 'login))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; register +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route register ("register") + (:requirement #'not-logged-on-p) + (finalize-page (rulisp.auth.view:register-form nil) + "Регистрация")) + +(defun form-field-value (field) + (hunchentoot:post-parameter field)) + +(defun form-field-empty-p (field) + (string= (form-field-value field) + "")) + +(defun check-register-form () + (let ((bads nil)) + (flet ((form-error-message (field message) + (push message bads) + (push field bads))) + (cond + ((form-field-empty-p "name") + (form-error-message :bad-name "empty")) + ((user-exist-p (form-field-value "name")) + (form-error-message :bad-name "exist"))) + + (cond + ((form-field-empty-p "email") (form-error-message :bad-email "empty")) + ((not (ppcre:scan *re-email-check* + (string-downcase (form-field-value "email")))) + (form-error-message :bad-email + "bad")) + ((email-exist-p (form-field-value "email")) + (form-error-message :bad-email + "exist"))) + + (cond + ((form-field-empty-p "password") + (form-error-message :bad-password + "empty")) + ((< (length (form-field-value "password")) 8) + (form-error-message :bad-password + "short"))) + + (unless (string= (form-field-value "password") + (form-field-value "re-password")) + (form-error-message :bad-re-password + "bad"))) + bads)) + +(restas:define-route register/post ("register" :method :post) + (:requirement #'not-logged-on-p) + (let ((form-bads (check-register-form)) + (login (form-field-value "name")) + (email (form-field-value "email")) + (password (form-field-value "password"))) + (finalize-page (if form-bads + (rulisp.auth.view:register-form (list* :name login + :email email + :password password + :re-password (form-field-value "re-password") + form-bads)) + (let ((invite (create-invite login email (password-cache password))) + (to (list email))) + (send-mail to + (rulisp.auth.view:confirmation-mail + (list :to to + :noreply-mail *noreply-email* + :subject (prepare-subject "Потверждение регистрации") + :host (hunchentoot:host) + :link (restas:genurl* 'accept-invitation :invite invite)))) + (rulisp.auth.view:register-send-mail nil))) + "Регистрация"))) + +(restas:define-route accept-invitation ("register/confirmation/:(invite)") + (:requirement #'not-logged-on-p) + (if (invite-exist-p invite) + (let ((account (create-account invite))) + (run-login (first account) + (third account)) + (finalize-page (rulisp.auth.view:success-registration nil) + "Регистрация завершена")) + hunchentoot:+HTTP-NOT-FOUND+)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; forgot password +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route forgot ("forgot") + (:requirement #'not-logged-on-p) + (finalize-page (rulisp.auth.view:forgot nil) + "Восстановление пароля")) + +(restas:define-route forgot/post ("forgot" :method :post) + (:requirement #'not-logged-on-p) + (let ((email-or-login (hunchentoot:post-parameter "email-or-login"))) + (if (or (not email-or-login) + (string= email-or-login "")) + (restas:redirect 'forgot) + (multiple-value-bind (mark login email) (create-forgot-mark email-or-login) + (declare (ignore login)) + (if mark + (progn + (send-mail (list email) + (rulisp.auth.view:forgot-mail (list :to (list email) + :noreply-mail *noreply-email* + :subject (prepare-subject "Восстановление пароля") + :host (hunchentoot:host) + :link (restas:genurl* 'reset-password :mark mark)))) + (finalize-page (rulisp.auth.view:forgot-send-mail nil) + "Восстановление пароля")) + (finalize-page (rulisp.auth.view:forgot (list :bad t)) + "Восстановление пароля")))))) + +(restas:define-route reset-password ("reset-password/:(mark)") + (:requirement #'not-logged-on-p) + (if (forgot-mark-exist-p mark) + (finalize-page (rulisp.auth.view:reset-password-form nil) + "Изменение пароля") + hunchentoot:+HTTP-NOT-FOUND+)) + +(restas:define-route reset-password/post ("reset-password/:(mark)" :method :post) + (:requirement #'not-logged-on-p) + (if (forgot-mark-exist-p mark) + (let ((bads nil)) + (flet ((form-error-message (field message) + (push message bads) + (push field bads))) + (cond + ((form-field-empty-p "password") + (form-error-message :bad-password + "empty")) + ((< (length (form-field-value "password")) 8) + (form-error-message :bad-password + "short"))) + (unless (string= (form-field-value "password") + (form-field-value "re-password")) + (form-error-message :bad-re-password + "bad"))) + (finalize-page (if bads + (rulisp.auth.view:reset-password-form (list* :password (form-field-value "password") + :re-password (form-field-value "re-password") + bads)) + (progn (change-password mark + (password-cache (hunchentoot:post-parameter "password"))) + (rulisp.auth.view:reset-password-success nil))) + "Изменение пароля")) + (restas:redirect 'forgot))) + + + diff --git a/src/auth/storage.lisp b/src/auth/storage.lisp new file mode 100644 index 0000000..e55cbc3 --- /dev/null +++ b/src/auth/storage.lisp @@ -0,0 +1,177 @@ +;;;; storage.lisp +;;;; +;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.auth) + +(restas:define-policy #:datastore + (:interface-package #:rulisp.auth.policy.datastore) + (:interface-method-template "~A") + (:internal-function-template "~A") + + (define-method check-user-password (login password)) + (define-method email-exist-p (email)) + (define-method user-exist-p (login)) + (define-method create-invite (login email password)) + (define-method invite-exist-p (invite)) + (define-method create-account (invite)) + (define-method create-forgot-mark (email)) + (define-method forgot-mark-exist-p (mark)) + (define-method change-password (forgot-mark password))) + + + +;;;; generic interface + +;; (defgeneric storage-check-user-password (storage login password)) + +;; (defgeneric storage-email-exist-p (storage email)) + +;; (defgeneric storage-user-exist-p (storage login)) + +;; (defgeneric storage-create-invite (storage login email password)) + +;; (defgeneric storage-invite-exist-p (storage invite)) + +;; (defgeneric storage-create-account (storage invite)) + +;; (defgeneric storage-create-forgot-mark (storage login-or-email)) + +;; (defgeneric storage-forgot-mark-exist-p (storage mark)) + +;; (defgeneric storage-change-password (storage forgot-makr password)) + +;;;; inner interface + +;; (defun check-user-password (login password) +;; (storage-check-user-password *storage* login password)) + +;; (defun email-exist-p (email) +;; (storage-email-exist-p *storage* email)) + +;; (defun user-exist-p (login) +;; (storage-user-exist-p *storage* login)) + +;; (defun create-invite (login email password) +;; (storage-create-invite *storage* login email password)) + +;; (defun invite-exist-p (invite) +;; (storage-invite-exist-p *storage* invite)) + +;; (defun create-account (invite) +;; (storage-create-account *storage* invite)) + +;; (defun create-forgot-mark (email) +;; (storage-create-forgot-mark *storage* email)) + +;; (defun forgot-mark-exist-p (mark) +;; (storage-forgot-mark-exist-p *storage* mark)) + +;; (defun change-passwowrd (forgot-mark password) +;; (storage-change-password *storage* forgot-mark password)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; storage in memory +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defclass memory-storage () +;; ((users :initarg :users :initform nil) +;; (invites :initform nil) +;; (forgots :initform nil))) + + +;; (defmethod storage-check-user-password ((storage memory-storage) login password) +;; (if (string= (third (find login +;; (slot-value storage 'users) +;; :key #'first +;; :test #'string=)) +;; password) +;; login)) + +;; (defmethod storage-user-exist-p ((storage memory-storage) login) +;; (find login +;; (slot-value storage 'users) +;; :key #'first +;; :test #'string=)) + +;; (defmethod storage-email-exist-p ((storage memory-storage) email) +;; (find email +;; (slot-value storage 'users) +;; :key #'second +;; :test #'string-equal)) + +;; (defmethod storage-create-invite ((storage memory-storage) login email password) +;; (let ((invite (calc-sha1-sum (format nil "~A~A~A" login email password)))) +;; (push (list invite +;; login +;; email +;; password) +;; (slot-value storage +;; 'invites)) +;; invite)) + +;; (defmethod storage-invite-exist-p ((storage memory-storage) invite) +;; (if (assoc invite +;; (slot-value storage 'invites) +;; :test #'string=) +;; t +;; nil)) + +;; (defmethod storage-create-account ((storage memory-storage) invite) +;; (let ((info (assoc invite +;; (slot-value storage 'invites) +;; :test #'string=))) +;; (when info +;; (push (cdr info) +;; (slot-value storage 'users)) +;; (setf (slot-value storage 'invites) +;; (delete info +;; (slot-value storage 'invites)))) +;; (cdr info))) + +;; (defmethod storage-create-forgot-mark ((storage memory-storage) login-or-email) +;; (let* ((info (find login-or-email +;; (slot-value storage 'users) +;; :test #'(lambda (x item) +;; (or (string= x (first item)) +;; (string= x (second item)))))) +;; (mark (if info (calc-sha1-sum (write-to-string info))))) +;; (when mark +;; (unless (find mark +;; (slot-value storage 'forgots) +;; :test #'string=) +;; (push (cons mark +;; info) +;; (slot-value storage 'forgots))) +;; (values mark +;; (first info) +;; (second info))))) + +;; (defmethod storage-forgot-mark-exist-p ((storage memory-storage) mark) +;; (find mark +;; (slot-value storage 'forgots) +;; :key #'car +;; :test #'string=)) + +;; (defmethod storage-change-password ((storage memory-storage) forgot-mark password) +;; (let ((info (find forgot-mark +;; (slot-value storage 'forgots) +;; :key #'car +;; :test #'string=))) +;; (setf (third (cdr info)) +;; password) +;; (setf (slot-value storage 'forgots) +;; (delete info +;; (slot-value storage 'forgots))))) + + +;; ;;;; default init *storage* + +;; (setf *storage* (make-instance 'memory-storage)) + +;; (create-account (create-invite "archimag" "archimag@gmail.com" (calc-md5-sum "123"))) + + diff --git a/src/auth/templates/forgot.tmpl b/src/auth/templates/forgot.tmpl new file mode 100644 index 0000000..fb56005 --- /dev/null +++ b/src/auth/templates/forgot.tmpl @@ -0,0 +1,125 @@ +// -*- mode: closure-template-html -*- +// +// forgot.tmpl +// +// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.auth.view} + +{template forgot} +
+
+

Забыли свой пароль?

+

Нам необходимо убедиться, что Вы имеете доступ к учётной записи электронной почты

+ + + + + + + + + + + + +
Логин или адрес электронной почты + {if $bad} +
Пользователь с таким логином или email не зарегестрирован
+ {/if} + +
+
+
+
+{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Forgot send mail + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template forgotSendMail} +
+

Забыли свой пароль?

+

Вам выслано письмо со ссылкой на продолжение.

+
+{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Reset password form + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template resetPasswordForm} +
+
+ + + + + + + + + + + + + + + + +
Новый Пароль + {switch $badPassword} + {case 'empty'}
Необходимо указать пароль
+ {case 'short'}
Должно быть не менее 8 символов
+ {/switch} + + +
Повторите Новый Пароль + {if $badRePassword} +
Пароли не совпадают
+ {/if} + +
+
+
+
+{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Reset password success + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template resetPasswordSuccess} +
+

Пароль успешно обновлён

+
+{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Mails + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template forgotMail} + {nil}To: {foreach $receiver in $to}{if not isFirst($receiver)}{sp}{/if}{$receiver}{/foreach}{\n} + {nil}From: {$noreplyMail}{\n} + {nil}Subject: {$subject}{\n} + {nil}Content-Type: text/html; charset=utf-8{\n} + {\n} + +

+ Вы попросили изменить свой пароль на сайте {$host}. + Вы можете это сделать по адрессу: {$link} +

+ +

+ Эта ссылка будет работоспособной в течении двух дней. + Если Вы не запрашивали это сообщение, то просто игнорируйте его. +

+ + Keeper +{/template} diff --git a/src/auth/templates/login.tmpl b/src/auth/templates/login.tmpl new file mode 100644 index 0000000..07a8107 --- /dev/null +++ b/src/auth/templates/login.tmpl @@ -0,0 +1,38 @@ +// -*- mode: closure-template-html -*- +// +// logim.tmpl +// +// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.auth.view} + +{template login} +
+ +
+{/template} diff --git a/src/auth/templates/register.tmpl b/src/auth/templates/register.tmpl new file mode 100644 index 0000000..9f6c2f6 --- /dev/null +++ b/src/auth/templates/register.tmpl @@ -0,0 +1,124 @@ +// -*- mode: closure-template-html -*- +// +// register.tmpl +// +// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.auth.view} + +{template registerForm} +
+

Создайте учётную запись

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Имя входа (логин): + {if $badName} +
+ {switch $badName} + {case 'empty'} Не указан логин + {case 'exist'} Пользователь с таким логином уже существует + {/switch} +
+ {/if} + +
Например: graham, Piter.Norvig
+
Ваш email: + {if $badEmail} +
+ {switch $badEmail} + {case 'empty'} Не указан email + {case 'bad'} Это не похоже на email + {case 'exist'} Пользователь с таким email уже существует + {/switch} +
+ {/if} + +
Укажите пароль: + {if $badPassword} +
+ {switch $badPassword} + {case 'empty'} Необходимо ввести пароль + {case 'short'} Слишком короткий + {/switch} +
+ {/if} + +
Минимальная длина - 8 символов
+
Введите пароль ещё раз: + {if $badRePassword} +
+ Пароли не совпадают +
+ {/if} + +
+ +
+
+
+{/template} + +{template registerSendMail} +
+

Вам выслано письмо со ссылкой на продолжение регистрации.

+
+{/template} + +{template confirmationMail} + {nil}To: {foreach $receiver in $to}{if not isFirst($receiver)}{sp}{/if}{$receiver}{/foreach}{\n} + {nil}From: {$noreplyMail}{\n} + {nil}Subject: {$subject}{\n} + {nil}Content-Type: text/html; charset=utf-8{\n} + {\n} + + Здравствуйте, +

+ Для завершения регистрации на {$host} перейдите по ссылке {$link}. +

+ +

+ Если Вы не регистрировались на сайте {$host}, то просто проигнорируйте это сообщение. +

+ + Keeper +{/template} + + +{template successRegistration} +
+ Поздравляем с успешной регистрацией! +
+{/template} + + diff --git a/src/packages.lisp b/src/packages.lisp index 9522f99..370b23a 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -38,3 +38,14 @@ (restas:define-module #:rulisp.jscl (:use #:cl #:rulisp.preferences) (:export #:jscl-main)) + +(restas:define-module #:rulisp.auth + (:use #:cl #:iter) + (:export #:*sendmail* + #:*noreply-email* + #:*re-email-check* + #:*finalize-page* + #:*cookie-auth-name* + #:*cookie-cipher-key* + #:*datastore* + #:*host*)) diff --git a/src/rulisp.lisp b/src/rulisp.lisp index c6dca4c..f658216 100644 --- a/src/rulisp.lisp +++ b/src/rulisp.lisp @@ -19,7 +19,7 @@ module)))) (let ((rulisp-module (find-upper-module restas:*module*))) (restas::with-module (gethash '-auth- (slot-value rulisp-module 'restas::children)) - (restas.simple-auth::compute-user-login-name))))) + (rulisp.auth::compute-user-login-name))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; rulisp templates @@ -94,14 +94,14 @@ ;; ;;;; auth -(restas:mount-module -auth- (#:restas.simple-auth) - (restas.simple-auth:*datastore* *rulisp-db-storage*) - (restas.simple-auth:*noreply-email* *noreply-mail-account*) - (restas.simple-auth:*cookie-cipher-key* *cookie-cipher-key*) - (restas.simple-auth:*finalize-page* (lambda (content) - (rulisp-finalize-page :title (getf content :title) - :css '("style.css") - :content (getf content :body))))) +(restas:mount-module -auth- (#:rulisp.auth) + (rulisp.auth:*datastore* *rulisp-db-storage*) + (rulisp.auth:*noreply-email* *noreply-mail-account*) + (rulisp.auth:*cookie-cipher-key* *cookie-cipher-key*) + (rulisp.auth:*finalize-page* (lambda (content) + (rulisp-finalize-page :title (getf content :title) + :css '("style.css") + :content (getf content :body))))) ;;;; forum @@ -110,7 +110,7 @@ (:render-method (lambda (obj) (rulisp-finalize-page :title (getf obj :title) - :content (restas:render-object (find-package '#:restas.forum.view) + :content (restas:render-object (find-package '#:restas.forum.view) obj) :css '("style.css" "jquery.wysiwyg.css" "forum.css" "colorize.css" ) :js (getf obj :js)))) diff --git a/src/storage.lisp b/src/storage.lisp index 67a9220..b268236 100644 --- a/src/storage.lisp +++ b/src/storage.lisp @@ -46,7 +46,7 @@ :single) -(defmethod restas.simple-auth.policy.datastore:check-user-password ((storage rulisp-db-storage) login password) +(defmethod rulisp.auth.policy.datastore:check-user-password ((storage rulisp-db-storage) login password) (with-db-storage storage (if (check-user-password* login password) login))) @@ -55,7 +55,7 @@ "select email from users where email = $1" :single) -(defmethod restas.simple-auth.policy.datastore:email-exist-p ((storage rulisp-db-storage) email) +(defmethod rulisp.auth.policy.datastore:email-exist-p ((storage rulisp-db-storage) email) (with-db-storage storage (check-email-exist* email))) @@ -63,25 +63,25 @@ "select login from users where login = $1" :single) -(defmethod restas.simple-auth.policy.datastore:user-exist-p ((storage rulisp-db-storage) login) +(defmethod rulisp.auth.policy.datastore:user-exist-p ((storage rulisp-db-storage) login) (with-db-storage storage (check-login-exist* login))) (postmodern:defprepared db-add-new-user "SELECT add_new_user($1, $2, $3, $4)" :single) -(defmethod restas.simple-auth.policy.datastore:create-invite ((storage rulisp-db-storage) login email password) +(defmethod rulisp.auth.policy.datastore:create-invite ((storage rulisp-db-storage) login email password) (let ((invite (calc-sha1-sum (format nil "~A~A~A" login email password)))) (with-db-storage storage (db-add-new-user login email password invite)) invite)) -(defmethod restas.simple-auth.policy.datastore:invite-exist-p ((storage rulisp-db-storage) invite) +(defmethod rulisp.auth.policy.datastore:invite-exist-p ((storage rulisp-db-storage) invite) (with-db-storage storage (postmodern:query (:select 'mark :from 'confirmations :where (:= 'mark invite)) :single))) -(defmethod restas.simple-auth.policy.datastore:create-account ((storage rulisp-db-storage) invite) +(defmethod rulisp.auth.policy.datastore:create-account ((storage rulisp-db-storage) invite) (with-db-storage storage (let* ((account (postmodern:query (:select 'users.user_id 'login 'email 'password :from 'users @@ -96,7 +96,7 @@ :where (:= 'mark invite)))) (cdr account)))) -(defmethod restas.simple-auth.policy.datastore:create-forgot-mark ((storage rulisp-db-storage) login-or-email) +(defmethod rulisp.auth.policy.datastore:create-forgot-mark ((storage rulisp-db-storage) login-or-email) (with-db-storage storage (let ((login-info (postmodern:query (:select 'user-id 'login 'email :from 'users :where (:and (:or (:= 'email login-or-email) @@ -111,14 +111,14 @@ (second login-info) (third login-info))))))) -(defmethod restas.simple-auth.policy.datastore:forgot-mark-exist-p ((storage rulisp-db-storage) mark) +(defmethod rulisp.auth.policy.datastore:forgot-mark-exist-p ((storage rulisp-db-storage) mark) (with-db-storage storage (postmodern:query (:select 'mark :from 'forgot :where (:= 'mark mark)) :single))) -(defmethod restas.simple-auth.policy.datastore:change-password ((storage rulisp-db-storage) mark password) +(defmethod rulisp.auth.policy.datastore:change-password ((storage rulisp-db-storage) mark password) (with-db-storage storage (postmodern:with-transaction () (postmodern:execute (:update 'users From 4de3453c56547e72f08855fd174987043a44eccf Mon Sep 17 00:00:00 2001 From: Hedin Date: Tue, 27 Mar 2018 09:50:46 +0300 Subject: [PATCH 2/7] Merge restas.planet into rulisp --- resources/planet/feed-icon-10x10.png | Bin 0 -> 469 bytes resources/planet/feed-icon-14x14.png | Bin 0 -> 689 bytes resources/planet/planet.css | 76 +++++++++++++++++ rulisp.asd | 14 ++- src/packages.lisp | 9 ++ src/planet/feed-parser.lisp | 123 +++++++++++++++++++++++++++ src/planet/planet.lisp | 86 +++++++++++++++++++ src/planet/planet.tmpl | 108 +++++++++++++++++++++++ src/planet/spider.lisp | 105 +++++++++++++++++++++++ src/rulisp.lisp | 14 +-- 10 files changed, 525 insertions(+), 10 deletions(-) create mode 100644 resources/planet/feed-icon-10x10.png create mode 100644 resources/planet/feed-icon-14x14.png create mode 100644 resources/planet/planet.css create mode 100644 src/planet/feed-parser.lisp create mode 100644 src/planet/planet.lisp create mode 100644 src/planet/planet.tmpl create mode 100644 src/planet/spider.lisp diff --git a/resources/planet/feed-icon-10x10.png b/resources/planet/feed-icon-10x10.png new file mode 100644 index 0000000000000000000000000000000000000000..cc869bc61785f4db646fcbbcfc87aa3d20d99eba GIT binary patch literal 469 zcmV;`0V@89P)b#`aw-kX_Si^Jc1|2c;v&L+N%#GTkbr^vx_L@0?2ue1vae8uy9 zW>j2Fwi~;wnv#w|%)>D{wT>10d6+ znvjX&#K$e}$~4lwrKocpr#p$RZpK^viI-7mZAGBOZfK!ocn0%!gWCL!dO5}Fox+@M z<8LitMCck7=WdtW+z{sJ1iSwiD)WlBvkT!CKn3HAn`5Jatl8=pf zWMv()t_|gz0w^mJ$i`l18o*uui>ycxWHsvP8s|%U9u%*Cx=p;;psT*)T^`{*rxCTS zWX}(wG=ZN^W3ms(Xv}CQKedl?b7Aoq{>2_>AN82ZL&^z8{|hhxfn}MuvYci literal 0 HcmV?d00001 diff --git a/resources/planet/feed-icon-14x14.png b/resources/planet/feed-icon-14x14.png new file mode 100644 index 0000000000000000000000000000000000000000..b3c949d2244f2c0c81d65e74719af2a1b56d06a3 GIT binary patch literal 689 zcmV;i0#5yjP)(tky!*UETcH-TCU7SrqEjJM#?B`_A)!p7(kFf9-P@=@15kkTkGK zgFusyy#KECqZzRdBLb=P?$(kUP;>kYTDeG&{|a+iOiRbI6nbQ)j#7bOf>iF=C+|_py<&Fo1F5cC*iEM?zZGC{ejNg4LWYp=S$L6Qaby6y zp$+F`250{%tU{Lg$5*ROH}y!1UKJS4*xqd7P(Y3JQF?lrnf?yerr%&6yGXLG1ur*B z{$&R1@Oj)yl@%rY5rh?j(j10Yz_DBs`AKFU_QnB;)(aqQmGi&ieOS|21^NP9UMpa< zU&p!f6RZ6Owp^X!EXA=0SbN&h?CrQK%Q3(=YBqqHD^9ZUM0Hxt-6-KT;>lf@j?Z+v zHm(}`>85I&E<7e}oz?6UwjAogowzGO8kSN7+2`b^$Az9L{K5*ko87EV45LT-`_##3 z>d3AGh@>=mbg34|6}+-gT9N+6Dr@44VEl44O&{&|w=qpbzC#iWMKa?5)>tI+KLQK@ Xq0QFqn(9Yl00000NkvXXu0mjfZ8t + + +(in-package :rulisp.planet) + +(defparameter *feeds-ns-map* '(("atom" "http://www.w3.org/2005/Atom"))) + +(defun make-author (name uri) + (list :name name + :uri uri)) + +(defun author-name (author) + (getf author :name)) + +(defun make-entry (&key title link id published updated content author) + (list :title title + :link link + :id id + :published published + :updated updated + :content content + :author author)) + +(defun entry-published-universal (entry) + (local-time:timestamp-to-universal (getf entry :published))) + + +(defun parse-atom-feed (rawfeed &optional category) + "Parse feed in Atom format" + (let ((xpath-all-entities (if category + (format nil "/atom:feed/atom:entry[atom:category/@term='~A']" category) + "/atom:feed/atom:entry")) + (author (make-author (xpath:find-string rawfeed + "/atom:feed/atom:title" + :ns-map *feeds-ns-map*) + (xpath:find-string rawfeed + "/atom:feed/atom:link[@rel='alternate']/@href" + :ns-map *feeds-ns-map*)))) + (cons author + (iter (for rawentry in-xpath-result xpath-all-entities on rawfeed with-ns-map *feeds-ns-map*) + (flet ((find-string (expr) + (xpath:find-string rawentry expr :ns-map *feeds-ns-map*))) + (collect (make-entry + :title (find-string "atom:title") + :link (find-string "atom:link[@rel = 'alternate' or not(@rel)]/@href") + :id (find-string "atom:id") + :published (local-time:parse-timestring (find-string "atom:published")) + :updated (find-string "atom:updated") + :content (or (find-string "atom:content") + (find-string "atom:summary")) + :author author))))))) + +(defun parse-rss-2.0-feed (rawfeed &optional category) + "Parse feed in RSS-2.0 format" + (let ((xpath-all-entities (if category + (format nil "/rss/channel/item[category = '~A']" category) + "/rss/channel/item")) + (author (make-author (xpath:find-string rawfeed "/rss/channel/title") + (xpath:find-string rawfeed "/rss/channel/link")))) + (cons author + (iter (for rawentry in-xpath-result xpath-all-entities on rawfeed) + (collect (make-entry + :title (xpath:find-string rawentry "title") + :link (xpath:find-string rawentry "link") + :id (xpath:find-string rawentry "guid") + :published (local-time:universal-to-timestamp + (net.telent.date:parse-time (xpath:find-string rawentry "pubDate"))) + :updated nil + :content (xpath:find-string rawentry "description") + :author author)))))) + +(defgeneric parse-feed (feed &optional category) + (:documentation "Parse feed in any format") + (:method (feed &optional category) + (xtree:with-parse-document (rawfeed feed) + (if rawfeed + (parse-feed rawfeed category))))) + +(defmethod parse-feed ((rawfeed xtree:document) &optional category) + (let* ((root-feed (xtree:root rawfeed)) + (name (xtree:local-name root-feed)) + (namespace (xtree:namespace-uri root-feed))) + (cond + ((and (string= name "feed") + (string= namespace "http://www.w3.org/2005/Atom")) (parse-atom-feed rawfeed category)) + ((and (not namespace) + (string= name "rss") + (string= "2.0" + (xtree:attribute-value root-feed + "version"))) (parse-rss-2.0-feed rawfeed category)) + (t (error "not supported feed type"))))) + + +(defclass feed-traits () + ((url :initarg :url) + (category :initarg :category :initform nil))) + +(defvar *feeds* nil) + +(defun feed (href &key category) + (push (make-instance 'feed-traits + :url (puri:parse-uri href) + :category category) + *feeds*)) + +(defparameter *planet.reader.package* + (defpackage :planet.reader + (:use) + (:import-from #:rulisp.planet #:feed))) + +(defun load-feeds-traits-from-file (path) + (let ((*feeds* nil) + (*package* *planet.reader.package*)) + (load path) + (nreverse *feeds*))) + + + diff --git a/src/planet/planet.lisp b/src/planet/planet.lisp new file mode 100644 index 0000000..5ad1e50 --- /dev/null +++ b/src/planet/planet.lisp @@ -0,0 +1,86 @@ +;;;; planet.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + + +(in-package #:rulisp.planet) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; compile view templates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (closure-template:compile-template :common-lisp-backend + (merge-pathnames "src/planet/planet.tmpl" + (asdf:component-pathname (asdf:find-system '#:rulisp))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; preferences +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *name* "PLANET") + +(defvar *feeds* nil) + +(defvar *spider* nil) + +(defvar *suggest-mail* nil) + +(defvar *schedule* '(:hour *)) + +(defvar *template* 'rulisp.planet.view:feed-html) + +(defvar *cache-dir* nil) + +(defmethod restas:initialize-module-instance ((module (eql #.*package*)) context) + (restas:with-context context + (when *feeds* + (restas:context-add-variable context + '*spider* + (make-instance 'spider + :feeds *feeds* + :schedule *schedule* + :cache-dir (if *cache-dir* + (ensure-directories-exist (merge-pathnames "spider/" + *cache-dir*)))))))) + +(defmethod restas:finalize-module-instance ((module (eql #.*package*)) context) + (let ((spider (restas:context-symbol-value context '*spider*))) + (when spider + (spider-stop-scheduler spider)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *resource-dir* + (merge-pathnames "resources/planet/" + (asdf:component-pathname (asdf:find-system '#:rulisp)))) + +(defun planet-path (path) + (merge-pathnames path *resource-dir*)) + +(restas:define-route planet-resources (":(file)") + (planet-path file)) + +(defun prepare-planet-data () + (list :entry-list (spider-syndicate-feed *spider*) + :authors (spider-feeds-authors *spider*) + :css (list (restas:genurl 'planet-resources :file "planet.css")) + :href-atom (restas:genurl* 'planet-atom) + :href-html (restas:genurl* 'planet-main) + :name *name* + :suggest-mail *suggest-mail*)) + +(restas:define-route planet-atom ("atom.xml") + (:content-type "application/atom+xml") + (:render-method 'rulisp.planet.view:atom-feed) + (prepare-planet-data)) + +(restas:define-route planet-main ("") + (:render-method #'(lambda (data) (funcall *template* data))) + (prepare-planet-data)) + diff --git a/src/planet/planet.tmpl b/src/planet/planet.tmpl new file mode 100644 index 0000000..6d6ba12 --- /dev/null +++ b/src/planet/planet.tmpl @@ -0,0 +1,108 @@ +// -*- mode: html -*- +// planet.tmpl +// +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +// See file COPYING for details. +// +// Author: Moskvitin Andrey + + +{namespace rulisp.planet.view} + +{template atom-feed} + {\n} + + + {$name} + + + {$hrefAlternate} + + {foreach $entry in $entryList} + + {$entry.title ? $entry.title : '*notitle*'} + {$entry.id} + + {$entry.published} + {if $entry.updated}{$entry.updated}{/if} + {$entry.content} + + {$entry.author.name} + {$entry.author.uri} + + + {/foreach} + +{/template} + +{template feed-html-authors} + +{/template} + +{template feed-html-content} + {foreach $entry in $entryList} +
+
+ {$entry.title ? $entry.title : '*notitle*'} + +
+ Источник: + {$entry.author.name} +
+
+ +
+ {$entry.content |noAutoescape} +
+
+ {/foreach} +{/template} + +{template feed-html-body} +
+
+ + {if $suggestMail} + + {/if} + +

Авторы

+ {call feed-html-authors data="all" /} +
+ +
+ {call feed-html-content data="all" /} +
+
+{/template} + +{template feed-html} + + {\n} + + + + {$name} + + {foreach $href in $css} + + {/foreach} + + + +

{$name}

+ + {call feed-html-body data="all" /} + + +{/template} diff --git a/src/planet/spider.lisp b/src/planet/spider.lisp new file mode 100644 index 0000000..1c8d311 --- /dev/null +++ b/src/planet/spider.lisp @@ -0,0 +1,105 @@ +;;;; spider.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.planet) + +(defclass spider () + ((feeds :initarg :feeds :initform nil) + (feeds-authors :initform nil :reader spider-feeds-authors) + (cache-dir :initarg :cache-dir :initform nil) + (syndicate-feed :initform nil :reader spider-syndicate-feed) + (scheduler :initform nil))) + + +(defun spider-feeds-traits (spider) + (let ((slot-feeds (slot-value spider 'feeds))) + (typecase slot-feeds + (cons slot-feeds) + (pathname (load-feeds-traits-from-file slot-feeds)) + (otherwise (error "Bad type of spider feeds: ~A" (type-of slot-feeds)))))) + +(defparameter *spider-readtable* (with-standard-io-syntax (copy-readtable))) + +(let ((*readtable* *spider-readtable*)) + (local-time:enable-read-macros)) + +(defun calc-sha1-sum (val) + "Calc sha1 sum of the val (string)" + (ironclad:byte-array-to-hex-string + (ironclad:digest-sequence :sha1 + (babel:string-to-octets val :encoding :utf-8)))) + + +(defun spider-load-all-feeds (spider) + (let ((authors nil) + (items nil) + (cache-dir (slot-value spider 'cache-dir))) + (iter (for traits in (spider-feeds-traits spider)) + (let ((cache (if cache-dir + (merge-pathnames (calc-sha1-sum (format nil + "~A&~A" + (slot-value traits 'url) + (slot-value traits 'category))) + cache-dir))) + (res (parse-feed (slot-value traits 'url) + (slot-value traits 'category)))) + (when cache + (if res + (with-open-file (out cache :direction :output :if-exists :supersede :if-does-not-exist :create) + (with-standard-io-syntax + (write res :stream out))) + (ignore-errors + (with-open-file (in cache :element-type 'extended-char) + (with-standard-io-syntax + (let ((*readtable* *spider-readtable*)) + (setf res + (read in)))))))) + (when res + (push (car res) + authors) + (setf items + (concatenate 'list + items + (cdr res)))))) + (setf (slot-value spider 'feeds-authors) + (sort authors + #'string< + :key #'author-name)) + (setf (slot-value spider 'syndicate-feed) + (iter (for item in (sort items #'> :key #'entry-published-universal)) + (for i from 0 below 50) + (collect item))) + spider)) + +(defun spider-stop-scheduler (spider) + "Stop spider scheduler" + (with-slots (scheduler) spider + (when scheduler + (sb-ext:unschedule-timer scheduler) + (setf scheduler nil)))) + +(defun spider-reset-scheduler (spider &key second minute hour day-of-month month year day-of-week) + "Reset spider scheduler" + (spider-stop-scheduler spider) + (with-slots (scheduler) spider + (setf scheduler + (clon:schedule-function #'(lambda () (spider-load-all-feeds spider)) + (clon:make-scheduler (clon:make-typed-cron-schedule :second second + :minute minute + :hour hour + :day-of-month day-of-month + :month month + :year year + :day-of-week day-of-week) + :allow-now-p t) + :thread t)))) + +(defmethod initialize-instance :after ((spider spider) &key (schedule '(:hour *)) &allow-other-keys) + (when schedule + (apply #'spider-reset-scheduler + spider + schedule))) diff --git a/src/rulisp.lisp b/src/rulisp.lisp index f658216..b272473 100644 --- a/src/rulisp.lisp +++ b/src/rulisp.lisp @@ -175,16 +175,16 @@ ;;;; Russian Lisp Planet -(restas:mount-module -planet- (#:restas.planet) +(restas:mount-module -planet- (#:rulisp.planet) (:url "planet") - (restas.planet:*suggest-mail* "archimag@lisper.ru") - (restas.planet:*feeds* (merge-pathnames "planet-feeds.lisp" *rulisp-path*)) - (restas.planet:*name* "Russian Lisp Planet") - (restas.planet:*cache-dir* (merge-pathnames "planet/" *cachedir*)) - (restas.planet:*template* (lambda (data) + (rulisp.planet:*suggest-mail* "archimag@lisper.ru") + (rulisp.planet:*feeds* (merge-pathnames "planet-feeds.lisp" *rulisp-path*)) + (rulisp.planet:*name* "Russian Lisp Planet") + (rulisp.planet:*cache-dir* (merge-pathnames "planet/" *cachedir*)) + (rulisp.planet:*template* (lambda (data) (rulisp-finalize-page :title "Russian Lisp Planet" :css '("style.css" "planet.css" "colorize.css") - :content (restas.planet.view:feed-html-body data))))) + :content (rulisp.planet.view:feed-html-body data))))) ;;;; static files From 4e12a64f891cdea22037e14b960694cef9da9163 Mon Sep 17 00:00:00 2001 From: Hedin Date: Wed, 28 Mar 2018 07:34:58 +0300 Subject: [PATCH 3/7] Merge restas.wiki into rulisp. Change auth headers --- rulisp.asd | 13 +++- src/auth/cookie.lisp | 2 +- src/auth/defmodule.lisp | 2 +- src/auth/sendmail.lisp | 2 +- src/auth/simple-auth.lisp | 2 +- src/auth/storage.lisp | 2 +- src/auth/templates/forgot.tmpl | 2 +- src/auth/templates/login.tmpl | 2 +- src/auth/templates/register.tmpl | 2 +- src/dokuwiki/render-html.lisp | 6 +- src/packages.lisp | 18 +++++ src/rulisp.lisp | 18 ++--- src/wiki/drawer.lisp | 83 +++++++++++++++++++++++ src/wiki/drawer.tmpl | 113 +++++++++++++++++++++++++++++++ src/wiki/routes.lisp | 64 +++++++++++++++++ src/wiki/storage.lisp | 112 ++++++++++++++++++++++++++++++ src/wiki/wiki.lisp | 25 +++++++ 17 files changed, 445 insertions(+), 23 deletions(-) create mode 100644 src/wiki/drawer.lisp create mode 100644 src/wiki/drawer.tmpl create mode 100644 src/wiki/routes.lisp create mode 100644 src/wiki/storage.lisp create mode 100644 src/wiki/wiki.lisp diff --git a/rulisp.asd b/rulisp.asd index c38ad72..3ce081e 100644 --- a/rulisp.asd +++ b/rulisp.asd @@ -12,7 +12,6 @@ #:simple-date #:postmodern #:zip - #:restas-wiki #:restas-colorize #:restas-directory-publisher #:restas-forum @@ -23,14 +22,15 @@ #:local-time #:clon #:closure-template - #:cl-libxml2) + #:cl-libxml2 + #:babel) :defsystem-depends-on (#:closure-template) :components ((:file "pref") (:module :src :components ((:file "packages") (:module "dokuwiki" :components ((:file "render-html")) - :depends-on ("packages")) + :depends-on ("packages" "wiki")) (:module "auth" :components ((:module "templates" :components ((:closure-template "forgot") @@ -47,6 +47,13 @@ (:file "spider" :depends-on ("feed-parser")) (:file "planet" :depends-on ("spider"))) :depends-on ("packages")) + (:module "wiki" + :components + ((:file "wiki") + (:file "storage") + (:file "drawer") + (:file "routes" :depends-on ("storage" "drawer"))) + :depends-on ("packages")) (:file "storage" :depends-on ("packages")) (:file "pcl" :depends-on ("rulisp")) (:file "jscl" :depends-on ("rulisp")) diff --git a/src/auth/cookie.lisp b/src/auth/cookie.lisp index ce3af60..cddb80b 100644 --- a/src/auth/cookie.lisp +++ b/src/auth/cookie.lisp @@ -1,6 +1,6 @@ ;;;; cookie.lisp ;;;; -;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/auth/defmodule.lisp b/src/auth/defmodule.lisp index f86e2fe..115a42f 100644 --- a/src/auth/defmodule.lisp +++ b/src/auth/defmodule.lisp @@ -1,6 +1,6 @@ ;;;; defplugin.lisp ;;;; -;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/auth/sendmail.lisp b/src/auth/sendmail.lisp index 7fc4e1e..2cf9931 100644 --- a/src/auth/sendmail.lisp +++ b/src/auth/sendmail.lisp @@ -1,6 +1,6 @@ ;;;; sendmail.lisp ;;;; -;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/auth/simple-auth.lisp b/src/auth/simple-auth.lisp index fc837bb..75e9dc5 100644 --- a/src/auth/simple-auth.lisp +++ b/src/auth/simple-auth.lisp @@ -1,6 +1,6 @@ ;;;; simple-auth.lisp ;;;; -;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/auth/storage.lisp b/src/auth/storage.lisp index e55cbc3..5782fbe 100644 --- a/src/auth/storage.lisp +++ b/src/auth/storage.lisp @@ -1,6 +1,6 @@ ;;;; storage.lisp ;;;; -;;;; This file is part of the restas-simple-auth library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/auth/templates/forgot.tmpl b/src/auth/templates/forgot.tmpl index fb56005..941d636 100644 --- a/src/auth/templates/forgot.tmpl +++ b/src/auth/templates/forgot.tmpl @@ -2,7 +2,7 @@ // // forgot.tmpl // -// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 // See file COPYING for details. // // Author: Moskvitin Andrey diff --git a/src/auth/templates/login.tmpl b/src/auth/templates/login.tmpl index 07a8107..ffc51b7 100644 --- a/src/auth/templates/login.tmpl +++ b/src/auth/templates/login.tmpl @@ -2,7 +2,7 @@ // // logim.tmpl // -// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 // See file COPYING for details. // // Author: Moskvitin Andrey diff --git a/src/auth/templates/register.tmpl b/src/auth/templates/register.tmpl index 9f6c2f6..129cc97 100644 --- a/src/auth/templates/register.tmpl +++ b/src/auth/templates/register.tmpl @@ -2,7 +2,7 @@ // // register.tmpl // -// This file is part of the restas-simple-auth library, released under Lisp-LGPL. +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 // See file COPYING for details. // // Author: Moskvitin Andrey diff --git a/src/dokuwiki/render-html.lisp b/src/dokuwiki/render-html.lisp index 8366f0d..1f183a4 100644 --- a/src/dokuwiki/render-html.lisp +++ b/src/dokuwiki/render-html.lisp @@ -419,7 +419,7 @@ ;;;; drawer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass dokuwiki-drawer (restas.wiki:drawer) ()) +(defclass dokuwiki-drawer (rulisp.wiki:drawer) ()) -(defmethod restas.wiki:generate-content-from-markup ((drawer dokuwiki-drawer) data) - (render-wiki-page-to-string (wiki-parser:parse :dokuwiki (call-next-method)))) \ No newline at end of file +(defmethod rulisp.wiki:generate-content-from-markup ((drawer dokuwiki-drawer) data) + (render-wiki-page-to-string (wiki-parser:parse :dokuwiki (call-next-method)))) diff --git a/src/packages.lisp b/src/packages.lisp index ccffa8c..5cf1137 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -58,3 +58,21 @@ #:*schedule* #:*cache-dir* #:*template*)) + +(restas:define-module #:rulisp.wiki + (:use #:cl #:iter) + (:export #:*index-page-title* + #:*wiki-user-function* + + ;; storage + #:*storage* + #:file-storage + #:storage-find-page + #:storage-save-page + #:storage-page-history + + ;; drawer + #:drawer + #:finalize-page + #:render-route-data + #:generate-content-from-markup)) diff --git a/src/rulisp.lisp b/src/rulisp.lisp index b272473..f6e4197 100644 --- a/src/rulisp.lisp +++ b/src/rulisp.lisp @@ -146,29 +146,29 @@ (defclass drawer (dokuwiki-drawer) ()) -(defmethod restas.wiki:finalize-page ((drawer drawer) content) +(defmethod rulisp.wiki:finalize-page ((drawer drawer) content) (rulisp-finalize-page :title (getf content :title) :css '("style.css" "wiki.css" "colorize.css") :content (concatenate 'string - (restas.wiki.view:show-page-menu (getf content :menu-links)) + (rulisp.wiki.view:show-page-menu (getf content :menu-links)) (getf content :content)))) -(restas:mount-module -wiki- (#:restas.wiki) +(restas:mount-module -wiki- (#:rulisp.wiki) (:url "wiki") (:render-method (make-instance 'drawer)) - (restas.wiki:*storage* (make-instance 'restas.wiki:file-storage :dir *wiki-dir*)) - (restas.wiki:*wiki-user-function* #'compute-user-login-name)) + (rulisp.wiki:*storage* (make-instance 'rulisp.wiki:file-storage :dir *wiki-dir*)) + (rulisp.wiki:*wiki-user-function* #'compute-user-login-name)) ;;;; articles -(restas:mount-module -articles- (#:restas.wiki) +(restas:mount-module -articles- (#:rulisp.wiki) (:url "articles") (:render-method (make-instance 'drawer)) - (restas.wiki:*index-page-title* "Статьи") - (restas.wiki:*storage* (make-instance 'restas.wiki:file-storage + (rulisp.wiki:*index-page-title* "Статьи") + (rulisp.wiki:*storage* (make-instance 'rulisp.wiki:file-storage :dir #P"/var/rulisp/articles/")) - (restas.wiki:*wiki-user-function* #'(lambda () + (rulisp.wiki:*wiki-user-function* #'(lambda () (find (compute-user-login-name) '("archimag" "dmitry_vk") :test #'string=)))) diff --git a/src/wiki/drawer.lisp b/src/wiki/drawer.lisp new file mode 100644 index 0000000..3d9e3e3 --- /dev/null +++ b/src/wiki/drawer.lisp @@ -0,0 +1,83 @@ +;;;; drawer.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.wiki) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; generic interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric finalize-page (drawer data) + (:documentation "Finalize page")) + +(defgeneric render-route-data (drawer data route ) + (:documentation "Render page for specific route")) + +(defgeneric generate-content-from-markup (drawer data) + (:documentation "Generate content of body")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; trivial implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass drawer () ()) + +(defmethod restas:render-object ((drawer drawer) (data list)) + (finalize-page drawer + (list* :content (render-route-data drawer + data + (restas:route-symbol restas:*route*)) + data))) + +(defmethod finalize-page ((drawer drawer) data) + (rulisp.wiki.view:finalize-page data)) + +(defmethod generate-content-from-markup ((drawer drawer) data) + data) + +(defmethod render-route-data ((drawer drawer) data route) + (funcall (find-symbol (symbol-name route) + '#:rulisp.wiki.view) + data)) + +(defmethod render-route-data ((drawer drawer) data (route (eql 'main-wiki-page))) + (render-route-data drawer data 'show-wiki-page)) + +(defmethod render-route-data ((drawer drawer) data (route (eql 'show-wiki-page))) + (if (getf data :content) + (generate-content-from-markup drawer (getf data :content)) + (rulisp.wiki.view:page-not-found (list :create-link + (restas:genurl 'edit-wiki-page + :page (getf data :title)))))) + + +(defmethod render-route-data ((drawer drawer) data (route (eql 'edit-wiki-page/preview))) + (render-route-data drawer + (if (getf data :content) + (list* :preview (generate-content-from-markup drawer (getf data :content)) + data) + data) + 'edit-wiki-page)) + + +(defparameter *date-format* '((:YEAR 4) #\- (:MONTH 2) #\- (:DAY 2) #\Space (:HOUR 2) #\: (:MIN 2))) + +(defmethod render-route-data ((drawer drawer) data (route (eql 'history-wiki-page))) + (call-next-method drawer + (list :title (getf data :title) + :history (iter (for item in (getf data :history)) + (collect (list* :date + (local-time:format-timestring nil + (local-time:universal-to-timestamp (getf item :date)) + :format *date-format*) + item)))) + route)) + +(defmethod render-route-data ((drawer drawer) data (route (eql 'show-archive-wiki-page))) + (if (getf data :content) + (generate-content-from-markup drawer (getf data :content)) + (rulisp.wiki.view:archive-not-found data))) diff --git a/src/wiki/drawer.tmpl b/src/wiki/drawer.tmpl new file mode 100644 index 0000000..61e151c --- /dev/null +++ b/src/wiki/drawer.tmpl @@ -0,0 +1,113 @@ +// -*- mode: closure-template-html -*- +// +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.wiki.view} + +{template finalizePage} + + {\n} + + + + + {if $title} + {$title} + {/if} + + + + {if $menuLinks} + {call showPageMenu data="$menuLinks" /} + {/if} + + {$content |noAutoescape} + + +{/template} + +{template showPageMenu} +
    + {if $editHref} +
  • + Edit +
    • + {/if} + + {if $currentVersionHref} +
  • + Current version +
    • + {/if} + + {if $historyHref} +
  • + History +
    • + {/if} + + {if $pdfHref} +
  • + PDF +
    • + {/if} + + {if $viewHref} +
  • + View +
    • + {/if} +
+{/template} + +{template generateBodyContent} +

{$title}

+ {$content |noAutoescape} +{/template} + +{template page-not-found} +

Эта страница ещё не существует

+ Создать +{/template} + +{template editWikiPage} +
+ + +
+ + + +
+
+ + {if $preview} + {$preview |noAutoescape} + {/if} +{/template} + +{template historyWikiPage} +

{$title}

+ +
    + {foreach $version in $history} +
  • + {$version.date} + {$version.name} + {$version.author} +
    • + {/foreach} +
+{/template} + + +{template archiveNotFound} + Archive file not found +{/template} + + diff --git a/src/wiki/routes.lisp b/src/wiki/routes.lisp new file mode 100644 index 0000000..13ef863 --- /dev/null +++ b/src/wiki/routes.lisp @@ -0,0 +1,64 @@ +;;;; wiki.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.wiki) + +(restas:define-route main-wiki-page ("") + (list* :title *index-page-title* + (show-wiki-page "index"))) + +(restas:define-route show-wiki-page (":(page)") + (list :title page + :content (storage-find-page *storage* page) + :menu-links (list :edit-href (restas:genurl 'edit-wiki-page + :page page) + :history-href (restas:genurl 'history-wiki-page + :page page)))) + +(restas:define-route edit-wiki-page ("edit/:(page)") + (:requirement #'wiki-user) + (list :title (format nil "Edit \"~A\"" page) + :content (storage-find-page *storage* page))) + +(restas:define-route edit-wiki-page/preview ("edit/:page" :method :post) + (:requirement (lambda () (hunchentoot:post-parameter "preview"))) + (list :title page + :content (hunchentoot:post-parameter "content"))) + +(restas:define-route edit-wiki-page/cancel ("edit/:page" :method :post) + (:requirement (lambda () (hunchentoot:post-parameter "cancel"))) + (restas:redirect 'show-wiki-page + :page page)) + +(restas:define-route edit-wiki-page/save ("edit/:page" :method :post) + (:requirement (lambda () (hunchentoot:post-parameter "save"))) + (storage-save-page *storage* + page + (hunchentoot:post-parameter "content") + (wiki-user)) + (restas:redirect 'show-wiki-page + :page page)) + +(restas:define-route history-wiki-page ("history/:(page)") + (:requirement #'wiki-user) + (list :title (format nil "History of page \"~A\"" page) + :history (iter (for item in (storage-page-history *storage* page)) + (collect (list* :href (restas:genurl 'show-archive-wiki-page + :page page + :version (getf item :date)) + item))) + :menu-links (list :view-href (restas:genurl 'show-wiki-page + :page page)))) + +(restas:define-route show-archive-wiki-page ("history/:(page)/:(version)") + (list :title (format nil "Archive version of ~A: ~A" page version) + :content (storage-page-version *storage* page version) + :menu-links (list :current-version-href (restas:genurl 'show-wiki-page + :page page) + :history-href (restas:genurl 'history-wiki-page + :page page)))) + diff --git a/src/wiki/storage.lisp b/src/wiki/storage.lisp new file mode 100644 index 0000000..4dedfce --- /dev/null +++ b/src/wiki/storage.lisp @@ -0,0 +1,112 @@ +;;;; storage.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.wiki) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; storage generic interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric storage-find-page (storage title) + (:documentation "Find wiki page in storage")) + +(defgeneric storage-save-page (storage title content author &optional comment) + (:documentation "Save wiki page in storage")) + +(defgeneric storage-page-history (storage title) + (:documentation "Return page history")) + +(defgeneric storage-page-version (storage title version) + (:documentation "Find wiki page version in storage")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; file storage +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-string-into-gzip-file (string path) + (with-open-file (ostream + path + :element-type '(unsigned-byte 8) + :direction :output + :if-exists :supersede) + (salza2:with-compressor (compressor 'salza2:gzip-compressor + :callback (salza2:make-stream-output-callback ostream)) + (salza2:compress-octet-vector (babel:string-to-octets string :encoding :utf-8) + compressor)))) + +(defun read-gzip-file-into-string (path) + (babel:octets-to-string (with-open-file (in path :element-type '(unsigned-byte 8)) + (zip:skip-gzip-header in) + (flex:with-output-to-sequence (out) + (zip:inflate in out))) + :encoding :utf-8)) + + +(defclass file-storage () + ((dir :initarg :dir :reader file-storage-dir))) + +(defun encode-page-title (title) + (closure-template:encode-uri title)) + +(defun file-storage-page-pathname (storage title) + (merge-pathnames (format nil "pages/~A" (encode-page-title title)) + (file-storage-dir storage))) + +(defun file-storage-changes-pathname (storage title) + (merge-pathnames (format nil "changes/~A.changes" (encode-page-title title)) + (file-storage-dir storage))) + +(defun file-storage-archive-pathname (storage page time) + (merge-pathnames (format nil "archive/~A.~A.gz" (encode-page-title page) time) + (file-storage-dir storage))) + +(defmethod storage-find-page ((storage file-storage) title) + (let ((path (file-storage-page-pathname storage title))) + (if (fad:file-exists-p path) + (alexandria:read-file-into-string path)))) + +(defmethod storage-save-page ((storage file-storage) title content author &optional comment) + (let* ((time (get-universal-time)) + (page-path (ensure-directories-exist (file-storage-page-pathname storage title))) + (changes-path (ensure-directories-exist (file-storage-changes-pathname storage title))) + (archive-path (ensure-directories-exist (file-storage-archive-pathname storage title time))) + (changes (nconc (if (fad:file-exists-p changes-path) + (with-open-file (in changes-path) + (with-standard-io-syntax + (read in)))) + (list (list time + author + (if (fad:file-exists-p page-path) + :edit + :create) + title + comment))))) + (with-open-file (out changes-path :direction :output :if-exists :supersede :if-does-not-exist :create) + (with-standard-io-syntax + (print changes + out))) + (write-string-into-gzip-file content archive-path) + (alexandria:write-string-into-file content + page-path + :if-exists :supersede + :if-does-not-exist :create))) + +(defmethod storage-page-history ((storage file-storage) title) + (let ((path (file-storage-changes-pathname storage title))) + (when (fad:file-exists-p path) + (iter (for item in (nreverse (with-open-file (in path) + (with-standard-io-syntax + (read in))))) + (collect (list :date (first item) + :name (fourth item) + :author (second item))))))) + +(defmethod storage-page-version ((storage file-storage) title version) + (let ((path (file-storage-archive-pathname storage title version))) + (if (fad:file-exists-p path) + (read-gzip-file-into-string path)))) diff --git a/src/wiki/wiki.lisp b/src/wiki/wiki.lisp new file mode 100644 index 0000000..d5ca3f7 --- /dev/null +++ b/src/wiki/wiki.lisp @@ -0,0 +1,25 @@ +;;;; packages.lisp +;;;; +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.wiki) + +(defvar *storage*) + +(defparameter *index-page-title* "index") + +(defparameter *wiki-dir* + (asdf:component-pathname (asdf:find-system '#:rulisp))) + +(closure-template:compile-template :common-lisp-backend + (merge-pathnames "src/wiki/drawer.tmpl" + *wiki-dir*)) + +(defvar *wiki-user-function* nil) + +(defun wiki-user () + (if *wiki-user-function* + (funcall *wiki-user-function*))) From b4805d62348eb1067b55fd6d5f2ddb48ce7c016d Mon Sep 17 00:00:00 2001 From: Hedin Date: Thu, 29 Mar 2018 09:17:49 +0300 Subject: [PATCH 4/7] Merge restas.colorize into rulisp, fix negative offset when have not entries in format module --- resources/colorize/colorize.css | 27 ++++++ resources/colorize/style.css | 11 +++ rulisp.asd | 10 ++- src/colorize/defmodule.lisp | 30 +++++++ src/colorize/drawer.lisp | 81 ++++++++++++++++++ src/colorize/drawer.tmpl | 145 ++++++++++++++++++++++++++++++++ src/colorize/routes.lisp | 80 ++++++++++++++++++ src/colorize/storage.lisp | 76 +++++++++++++++++ src/packages.lisp | 26 ++++++ src/rulisp.lisp | 12 +-- src/storage.lisp | 22 ++--- 11 files changed, 501 insertions(+), 19 deletions(-) create mode 100644 resources/colorize/colorize.css create mode 100644 resources/colorize/style.css create mode 100644 src/colorize/defmodule.lisp create mode 100644 src/colorize/drawer.lisp create mode 100644 src/colorize/drawer.tmpl create mode 100644 src/colorize/routes.lisp create mode 100644 src/colorize/storage.lisp diff --git a/resources/colorize/colorize.css b/resources/colorize/colorize.css new file mode 100644 index 0000000..494d1b3 --- /dev/null +++ b/resources/colorize/colorize.css @@ -0,0 +1,27 @@ +.symbol { color : #770055; background-color : transparent; border: 0px; margin: 0px;} +a.symbol:link { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +.special { color : #FF5000; background-color : inherit; } +.keyword { color : #770000; background-color : inherit; } +.comment { color : #007777; background-color : inherit; } +.string { color : #777777; background-color : inherit; } +.character { color : #0055AA; background-color : inherit; } +.syntaxerror { color : #FF0000; background-color : inherit; } +span.paren1:hover { color : inherit; background-color : #BAFFFF; } +span.paren2:hover { color : inherit; background-color : #FFCACA; } +span.paren3:hover { color : inherit; background-color : #FFFFBA; } +span.paren4:hover { color : inherit; background-color : #CACAFF; } +span.paren5:hover { color : inherit; background-color : #CAFFCA; } +span.paren6:hover { color : inherit; background-color : #FFBAFF; } + +.code { + background-color: #eee; + border: 1px solid #d0d0d0; + margin: 0.2em; + padding: 0.5em; + font-family: "Courier New", monospace; + font-size: 90%; + overflow: auto; +} \ No newline at end of file diff --git a/resources/colorize/style.css b/resources/colorize/style.css new file mode 100644 index 0000000..f5d0ac9 --- /dev/null +++ b/resources/colorize/style.css @@ -0,0 +1,11 @@ + +.colorize-top-menu { padding-left: 0; padding-bottom: 0.2em; margin: 0; border-bottom: 1px solid gray;} + +.colorize-top-menu li {display: inline; list-style-type: none; margin-right: 0.3em;} + +.colorize-list-nav {text-align: right; padding: 0.2em; margin-bottom: 0.2em; border-bottom: 1px solid gray; } + +.paste { margin: 0.5em;} +.info { font-size: 90%; color: gray; } + +.paste-detail { margin-top: 1em; } diff --git a/rulisp.asd b/rulisp.asd index 3ce081e..468598d 100644 --- a/rulisp.asd +++ b/rulisp.asd @@ -12,7 +12,6 @@ #:simple-date #:postmodern #:zip - #:restas-colorize #:restas-directory-publisher #:restas-forum #:xfactory @@ -23,7 +22,8 @@ #:clon #:closure-template #:cl-libxml2 - #:babel) + #:babel + #:colorize) :defsystem-depends-on (#:closure-template) :components ((:file "pref") (:module :src @@ -54,6 +54,12 @@ (:file "drawer") (:file "routes" :depends-on ("storage" "drawer"))) :depends-on ("packages")) + (:module "colorize" + :components ((:file "defmodule") + (:file "storage" :depends-on ("defmodule")) + (:file "drawer" :depends-on ("defmodule")) + (:file "routes" :depends-on ("storage" "drawer"))) + :depends-on ("packages")) (:file "storage" :depends-on ("packages")) (:file "pcl" :depends-on ("rulisp")) (:file "jscl" :depends-on ("rulisp")) diff --git a/src/colorize/defmodule.lisp b/src/colorize/defmodule.lisp new file mode 100644 index 0000000..7e05581 --- /dev/null +++ b/src/colorize/defmodule.lisp @@ -0,0 +1,30 @@ +;;;; packages.lisp +;;;; +;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.colorize) + +;;;; load templates + +(defparameter *colorize-template-path* + (merge-pathnames "src/colorize/drawer.tmpl" + (asdf:component-pathname (asdf:find-system '#:rulisp)))) + +(closure-template:compile-template :common-lisp-backend + *colorize-template-path*) + +;;;; preferences + +(defvar *max-on-page* 10) + +(defvar *storage* nil) + +(defparameter *colorize-user-function* + #'(lambda () "anonymous")) + +(defun colorize-user () + (if *colorize-user-function* + (funcall *colorize-user-function*))) diff --git a/src/colorize/drawer.lisp b/src/colorize/drawer.lisp new file mode 100644 index 0000000..f2e78d4 --- /dev/null +++ b/src/colorize/drawer.lisp @@ -0,0 +1,81 @@ +;;;; drawer.lisp +;;;; +;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.colorize) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; generic interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric finalize-page (drawer data) + (:documentation "Finalize page")) + +(defgeneric render-route-data (drawer data route ) + (:documentation "Render page for specific route")) + +(defgeneric colorize (drawer code lang) + (:documentation "Make highlight html from code") + (:method (drawer code lang) + (colorize::html-colorization (intern lang :keyword) code))) + +(defgeneric colorize-langs (drawer) + (:documentation "List of supported languages") + (:method (drawer) + (iter (for (id . title) in (colorize:coloring-types)) + (collect (list :id (symbol-name id) + :title title))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; default implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass drawer () ()) + +(defmethod finalize-page ((drawer drawer) data) + (rulisp.colorize.view:finalize-page data)) + + +(defmethod restas:render-object ((drawer drawer) (data list)) + (let ((content (render-route-data drawer + data + (restas:route-symbol restas:*route*))) + (menu (rulisp.colorize.view:main-menu + (list :href-all (restas:genurl 'list-notes) + :href-create (restas:genurl 'create-note))))) + (finalize-page drawer + (list :content content + :menu menu + :title (getf data :title))))) + + +(defmethod render-route-data ((drawer drawer) (data list) route) + (funcall (find-symbol (symbol-name route) + '#:rulisp.colorize.view) + data)) + +(defmethod render-route-data ((drawer drawer) (data list) (route (eql 'view-note))) + (call-next-method drawer + (list* :code (colorize drawer + (getf data :code) + (getf data :lang)) + data) + route)) + +(defmethod render-route-data ((drawer drawer) (data list) (route (eql 'create-note))) + (call-next-method drawer + (list* :langs (colorize-langs drawer) + data) + route)) + +(defmethod render-route-data ((drawer drawer) (data list) (route (eql 'preview-note))) + (call-next-method drawer + (list* :langs (colorize-langs drawer) + :preview (colorize drawer + (getf data :code) + (getf data :lang)) + data) + route)) diff --git a/src/colorize/drawer.tmpl b/src/colorize/drawer.tmpl new file mode 100644 index 0000000..49a2f08 --- /dev/null +++ b/src/colorize/drawer.tmpl @@ -0,0 +1,145 @@ +// -*- mode: closure-template-html -*- +// colorize.tmpl +// +// This file is part of the restas-colorize library, released under Lisp-LGPL. +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.colorize.view} + +{template finalizePage} + + {\n} + + + + + {if $title} + {$title} + {/if} + + + + {$menu |noAutoescape} + + {$content |noAutoescape} + + +{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Show main menu + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template main-menu} + +{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Show note info + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template show-note-info} +
+ Автор: {$author} - {$date} +
+{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Show list notes + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template list-notes} +
+ {if $hrefAfter}« Позже{/if} + {$first} - {min($first + length($notes) - 1, $totalCount)} + из {$totalCount} + {if $hrefBefore}Раньше »{/if} +
+ + {foreach $note in $notes} +
+ {$note.title != '' ? $note.title : '*notitle*'} + {call show-note-info data="$note" /} +
+ {/foreach} +{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Show one note + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template view-note} +
+ {$title} + {call show-note-info data="all" /} +
+ {$code |noAutoescape} +
+
+{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Create note form + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template create-note} +
+ + + + {if $preview and $author} + + + + + {/if} + + + + + + +
Описание: + +
Форматировать как: + +
+ + + {if $preview and $author} + + {/if} + + {if $preview} +

Предварительный просмотр

+
+ {$preview |noAutoescape} +
+ + HTML-код + 
+                {$preview}
+
+ {/if} +
+{/template} + +{template preview-note} + {call create-note data="all" /} +{/template} diff --git a/src/colorize/routes.lisp b/src/colorize/routes.lisp new file mode 100644 index 0000000..93432bb --- /dev/null +++ b/src/colorize/routes.lisp @@ -0,0 +1,80 @@ +;;;; colorize.lisp +;;;; +;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.colorize) + +(defun note-plist/short (note) + (list :href (restas:genurl 'view-note :id (note-id note)) + :date (local-time:format-timestring nil (note-date note)) + :title (note-title note) + :author (note-author note))) + +(defun note-plist (note) + (list* :title (note-title note) + :code (note-code note) + :lang (note-lang note) + (note-plist/short note))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; routes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route main ("") + (restas:redirect 'list-notes)) + +(restas:define-route list-notes ("all") + (let* ((total-count (storage-count-notes *storage*)) + (start (min (max (or (ignore-errors (parse-integer (hunchentoot:get-parameter "start"))) + 1) + 1) + total-count))) + (list :title "All notes" + :notes (iter (for note in (storage-list-notes *storage* + (if (> start 0) (1- start) 0) + *max-on-page*)) + (collect (note-plist/short note))) + :first start + :total-count total-count + :href-before (if (< (+ (1- start) *max-on-page*) + total-count) + (format nil + "~A?start=~A" + (restas:genurl 'list-notes) + (+ start *max-on-page*))) + :href-after (if (> start 1) + (format nil + "~A?start=~A" + (restas:genurl 'list-notes) + (max (- start *max-on-page*) 1)))))) + +(restas:define-route view-note (":id") + (:sift-variables (id 'integer)) + (note-plist (storage-get-note *storage* id))) + +(restas:define-route create-note ("create") + (list :title "Создать")) + +(restas:define-route preview-note ("create" :method :post) + (:requirement #'(lambda () (hunchentoot:post-parameter "preview"))) + (list :title (hunchentoot:post-parameter "title") + :author (colorize-user) + :code (hunchentoot:post-parameter "code") + :lang (hunchentoot:post-parameter "lang"))) + + +(restas:define-route save-note ("create" :method :post) + (:requirement #'(lambda () (hunchentoot:post-parameter "save"))) + (let ((author (colorize-user))) + (if author + (restas:redirect 'view-note + :id (note-id (storage-add-note *storage* + (make-instance 'note + :code (hunchentoot:post-parameter "code") + :author author + :lang (hunchentoot:post-parameter "lang") + :title (hunchentoot:post-parameter "title"))))) + hunchentoot:+http-forbidden+))) diff --git a/src/colorize/storage.lisp b/src/colorize/storage.lisp new file mode 100644 index 0000000..a0f6475 --- /dev/null +++ b/src/colorize/storage.lisp @@ -0,0 +1,76 @@ +;;;; storage.lisp +;;;; +;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.colorize) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; generic storage interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric storage-count-notes (storage)) + +(defgeneric storage-list-notes (storage offset limit)) + +(defgeneric storage-get-note (storage id)) + +(defgeneric storage-add-note (storage note)) + +(defgeneric storage-remove-note (storage id)) + +(defclass note () + ((id :initarg :id :initform nil :accessor note-id) + (date :initarg :date :initform nil :accessor note-date) + (author :initarg :author :initform nil :accessor note-author) + (title :initarg :title :initform nil :accessor note-title) + (lang :initarg :lang :initform nil :accessor note-lang) + (code :initarg :code :initform nil :accessor note-code))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; implementation storage in memory +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass memory-storage () + ((notes :initform nil) + (last-id :initform 0))) + +(defmethod storage-count-notes ((storage memory-storage)) + (length (slot-value storage 'notes))) + +(defmethod storage-list-notes ((storage memory-storage) offset limit) + (let* ((notes (slot-value storage 'notes)) + (len (length notes)) + (end (+ limit offset))) + (if (and (not (minusp offset)) + (> len offset)) + (subseq notes + offset + (if (and notes (< end len)) + end))))) + +(defmethod storage-get-note ((storage memory-storage) id) + (find id + (slot-value storage 'notes) + :key #'note-id)) + +(defmethod storage-add-note ((storage memory-storage) note) + (setf (slot-value note 'id) + (incf (slot-value storage 'last-id))) + (setf (slot-value note 'date) + (local-time:now)) + (push note + (slot-value storage 'notes)) + note) + +(defmethod storage-remove-note (storage id) + (setf (slot-value storage 'notes) + (remove id + (slot-value storage 'notes) + :key #'(lambda (note) (getf note :id))))) + +;;;; set default value of *storage* + +(setf *storage* (make-instance 'memory-storage)) diff --git a/src/packages.lisp b/src/packages.lisp index 5cf1137..223d3f8 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -76,3 +76,29 @@ #:finalize-page #:render-route-data #:generate-content-from-markup)) + +(restas:define-module #:rulisp.colorize + (:use #:cl #:iter) + (:export #:*storage* + #:*finalize-page* + #:*colorize-user-function* + #:*max-on-page* + ;; note + #:note + #:note-id + #:note-title + #:note-author + #:note-code + #:note-date + #:note-lang + ;; storage + #:storage-count-notes + #:storage-list-notes + #:storage-get-note + #:storage-add-note + #:storage-remove-note + ;; + #:finalize-page + #:render-route-data + #:colorize + #:colorize-langs)) diff --git a/src/rulisp.lisp b/src/rulisp.lisp index f6e4197..c2f806c 100644 --- a/src/rulisp.lisp +++ b/src/rulisp.lisp @@ -120,9 +120,9 @@ ;;;; format -(defclass pastebin-drawer (restas.colorize::drawer) ()) +(defclass pastebin-drawer (rulisp.colorize::drawer) ()) -(defmethod restas.colorize::finalize-page ((drawer pastebin-drawer) data) +(defmethod rulisp.colorize::finalize-page ((drawer pastebin-drawer) data) (rulisp-finalize-page :title (getf data :title) :css '("style.css" "colorize.css") :content (concatenate 'string @@ -130,12 +130,12 @@ (getf data :content)))) -(restas:mount-module -format- (#:restas.colorize) +(restas:mount-module -format- (#:rulisp.colorize) (:url "apps/format/") (:render-method (make-instance 'pastebin-drawer)) - (restas.colorize:*max-on-page* 15) - (restas.colorize:*storage* *rulisp-db-storage*) - (restas.colorize:*colorize-user-function* #'compute-user-login-name)) + (rulisp.colorize:*max-on-page* 15) + (rulisp.colorize:*storage* *rulisp-db-storage*) + (rulisp.colorize:*colorize-user-function* #'compute-user-login-name)) ;;;; jscl diff --git a/src/storage.lisp b/src/storage.lisp index b268236..d825a02 100644 --- a/src/storage.lisp +++ b/src/storage.lisp @@ -346,7 +346,7 @@ ;;; pastebin ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod restas.colorize:storage-count-notes ((storage rulisp-db-storage)) +(defmethod rulisp.colorize:storage-count-notes ((storage rulisp-db-storage)) (with-db-storage storage (postmodern:query (:select (:count '*) :from 'formats) :single))) @@ -357,10 +357,10 @@ ORDER BY f.created DESC LIMIT $2 OFFSET $1") -(defmethod restas.colorize:storage-list-notes ((storage rulisp-db-storage) offset limit) +(defmethod rulisp.colorize:storage-list-notes ((storage rulisp-db-storage) offset limit) (with-db-storage storage (iter (for item in (select-formats* offset limit)) - (collect (make-instance 'restas.colorize:note + (collect (make-instance 'rulisp.colorize:note :id (first item) :author (second item) :title (third item) @@ -372,10 +372,10 @@ WHERE format_id = $1" :row) -(defmethod restas.colorize:storage-get-note ((storage rulisp-db-storage) id) +(defmethod rulisp.colorize:storage-get-note ((storage rulisp-db-storage) id) (with-db-storage storage (let ((raw (get-note* id))) - (make-instance 'restas.colorize:note + (make-instance 'rulisp.colorize:note :id id :author (first raw) :title (second raw) @@ -383,19 +383,19 @@ :date (local-time:universal-to-timestamp (simple-date:timestamp-to-universal-time (fourth raw))) :lang (fifth raw))))) -(defmethod restas.colorize:storage-add-note ((storage rulisp-db-storage) note) +(defmethod rulisp.colorize:storage-add-note ((storage rulisp-db-storage) note) (with-db-storage storage (let ((id (postmodern:query (:select (:nextval "formats_format_id_seq")) :single)) (user-id (postmodern:query (:select 'user-id :from 'users - :where (:= 'login (restas.colorize:note-author note))) + :where (:= 'login (rulisp.colorize:note-author note))) :single))) (postmodern:execute (:insert-into 'formats :set 'format-id id 'user-id user-id - 'title (restas.colorize:note-title note) - 'code (restas.colorize:note-code note) - 'lang (restas.colorize:note-lang note))) - (setf (restas.colorize:note-id note) + 'title (rulisp.colorize:note-title note) + 'code (rulisp.colorize:note-code note) + 'lang (rulisp.colorize:note-lang note))) + (setf (rulisp.colorize:note-id note) id)) note)) From 6fc29cd728c11af47fbd5728a58d4a20e8a9053b Mon Sep 17 00:00:00 2001 From: Hedin Date: Thu, 29 Mar 2018 09:43:50 +0300 Subject: [PATCH 5/7] Merge restas.forum into rulisp --- rulisp.asd | 9 +- src/forum/defmodule.lisp | 30 ++++ src/forum/forum.lisp | 307 +++++++++++++++++++++++++++++++++++++++ src/forum/forum.tmpl | 285 ++++++++++++++++++++++++++++++++++++ src/forum/storage.lisp | 103 +++++++++++++ src/packages.lisp | 28 ++++ src/rulisp.lisp | 10 +- src/storage.lisp | 30 ++-- 8 files changed, 780 insertions(+), 22 deletions(-) create mode 100644 src/forum/defmodule.lisp create mode 100644 src/forum/forum.lisp create mode 100644 src/forum/forum.tmpl create mode 100644 src/forum/storage.lisp diff --git a/rulisp.asd b/rulisp.asd index 468598d..8262c6e 100644 --- a/rulisp.asd +++ b/rulisp.asd @@ -13,7 +13,6 @@ #:postmodern #:zip #:restas-directory-publisher - #:restas-forum #:xfactory #:cl-typesetting #:wiki-parser @@ -23,7 +22,8 @@ #:closure-template #:cl-libxml2 #:babel - #:colorize) + #:colorize + #:metabang-bind) :defsystem-depends-on (#:closure-template) :components ((:file "pref") (:module :src @@ -60,6 +60,11 @@ (:file "drawer" :depends-on ("defmodule")) (:file "routes" :depends-on ("storage" "drawer"))) :depends-on ("packages")) + (:module "forum" + :components ((:file "defmodule") + (:file "storage" :depends-on ("defmodule")) + (:file "forum" :depends-on ("storage"))) + :depends-on ("packages")) (:file "storage" :depends-on ("packages")) (:file "pcl" :depends-on ("rulisp")) (:file "jscl" :depends-on ("rulisp")) diff --git a/src/forum/defmodule.lisp b/src/forum/defmodule.lisp new file mode 100644 index 0000000..0629d4f --- /dev/null +++ b/src/forum/defmodule.lisp @@ -0,0 +1,30 @@ +;;;; packages.lisp +;;;; +;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.forum) + +(defparameter *storage* nil) + +(defparameter *site-name* nil) + +(defparameter *rss-item-count* 20) + +(defparameter *max-topic-on-page* 10) + +(defparameter *max-reply-on-page* 50) + +(defparameter *user-name-function* nil) + +(defparameter *rulisp-pathname* (asdf:component-pathname (asdf:find-system '#:rulisp))) + +(restas:mount-module resources (#:restas.directory-publisher) + (restas.directory-publisher:*directory* (merge-pathnames "resources/" *rulisp-pathname*)) + (restas.directory-publisher:*autoindex* nil)) + +(closure-template:compile-template :common-lisp-backend + (merge-pathnames "src/forum/forum.tmpl" + *rulisp-pathname*)) diff --git a/src/forum/forum.lisp b/src/forum/forum.lisp new file mode 100644 index 0000000..79c48f1 --- /dev/null +++ b/src/forum/forum.lisp @@ -0,0 +1,307 @@ +;;;; forum.lisp +;;;; +;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.forum) + +;;; aux + +(defun user-name () + (if *user-name-function* + (funcall *user-name-function*))) + +(defun parse-start () + (or (ignore-errors (parse-integer (hunchentoot:get-parameter "start"))) + 0)) + +(defun forum-info-plist (info) + (list :title (second info) + :href (restas:genurl 'list-topics + :forum-id (first info)))) + +(defun topic-last-page-id (topic-id &optional topic-reply-count) + (ceiling (or topic-reply-count + (storage-topic-reply-count *storage* topic-id)) + *max-reply-on-page*)) + +(defun topic-pages (topic-id current &key topic-reply-count ) + (cons (list :number 1 + :href (restas:genurl 'view-topic + :topic-id topic-id) + :current (= 1 current)) + (iter (for i from 2 to (topic-last-page-id topic-id topic-reply-count)) + (collect (list :number i + :href (restas:genurl 'view-topic-page + :topic-id topic-id + :page-id i) + :current (= i current)))))) + +(defun site-name () + (or *site-name* + (if (boundp 'hunchentoot:*request*) + (hunchentoot:host)) + "RULISP-FORUMS")) + +(defun js-urls () + (iter (for item in '("jquery.js" "jquery.wysiwyg.js" "jqModal.js" "forum.js")) + (collect (restas:genurl 'resources.route + :path (list "js" item))))) + +(defun colorize-traits () + (list :href (restas:genurl 'colorize-code) + :langs (iter (for (id . title) in (colorize:coloring-types)) + (collect (list :id (symbol-name id) + :title title))))) + +;;;; list all forums + +(restas:define-route list-forums ("") + (list :forums (iter (for forum in (storage-list-forums *storage*)) + (collect (forum-info-plist forum))) + :feed-href (restas:genurl 'all-forums-rss) + :title "Все форумы")) + +;;;; view forum topics + +(restas:define-route list-topics (":forum-id") + (bind:bind ((start (parse-start)) + ((title total-count) (storage-forum-info *storage* forum-id)) + (href (restas:genurl 'list-topics :forum-id forum-id)) + (adminp (storage-admin-p *storage* (user-name)))) + (flet ((self-url (start) + (format nil "~A?start=~A" href start))) + (print (js-urls)) + (list :title title + :js (js-urls) + :css '("jquery.wysiwyg.css") + :href-rss (restas:genurl 'forum-rss :forum-id forum-id) + :total-count total-count + :list-forums-href (restas:genurl 'list-forums) + :href-before (if (< (+ (1- start) *max-topic-on-page*) + total-count) + (self-url (+ start *max-topic-on-page*))) + :href-after (if (> start 0) + (self-url (max (- start *max-topic-on-page*) 0))) + :topics (iter (for topic in (storage-list-topics *storage* forum-id *max-topic-on-page* start)) + (collect (list* :href (restas:genurl 'view-topic + :topic-id (getf topic :id)) + :pages (topic-pages (getf topic :id) + -1 + :topic-reply-count (getf topic :message-count)) + :href-delete (if adminp + (restas:genurl 'delete-topic + :topic-id (getf topic :id))) + topic))) + :first (1+ start) + :can-create-new-topic (user-name) + :colorize (colorize-traits))))) + +;;;; create new topic + +(restas:define-route create-topic (":forum-id" :method :post) + (:requirement 'user-name) + (let ((title (hunchentoot:post-parameter "title")) + (body (hunchentoot:post-parameter "body"))) + (unless (or (string= title "") + (string= body "")) + (storage-create-topic *storage* + forum-id + title + body + (user-name))) + (restas:redirect 'list-topics :forum-id forum-id))) + + +;;;; delete topic + +(restas:define-route delete-topic ("thread/delete/:topic-id") + (:requirement 'user-name) + (:sift-variables (topic-id 'integer)) + (if (storage-admin-p *storage* (user-name)) + (restas:redirect 'list-topics + :forum-id (storage-delete-topic *storage* topic-id)) + hunchentoot:+http-forbidden+)) + +;;;; view-topic-page + + +(restas:define-route view-topic-page ("thread/:topic-id/page:(page-id)") + (:sift-variables (topic-id 'integer) (page-id 'integer)) + (let* ((message (storage-topic-message *storage* topic-id)) + (origin-message-id (getf message :message-id)) + (start (max (* *max-reply-on-page* + (1- page-id)) + 0)) + (user (user-name)) + (adminp (if user (storage-admin-p *storage* user)))) + (list :list-forums-href (restas:genurl 'list-forums) + :js (js-urls) + :rss-href (restas:genurl 'topic-rss + :topic-id topic-id) + :parent-forum (forum-info-plist (getf message :forum)) + :message (list* :href-reply (restas:genurl 'create-reply + :message-id origin-message-id) + message) + :pages (topic-pages topic-id page-id) + :replies (iter (for item in (storage-topic-replies *storage* + topic-id + *max-reply-on-page* + start)) + (for reply-id = (getf item :id)) + (collect (list* :href-delete (if adminp + (restas:genurl 'delete-message + :reply-id reply-id)) + :href (restas:genurl 'view-reply + :reply-id reply-id) + :href-reply (restas:genurl 'create-reply + :message-id reply-id) + :prev-msg (let ((prev-id (getf item :prev-id))) + (if (and (not (eql prev-id :null)) + (not (eql prev-id origin-message-id))) + (list :author (getf item :prev-author) + :created (getf item :prev-created) + :href (restas:genurl 'view-reply + :reply-id (getf item :prev-id))))) + item))) + :can-create-message user + :title (getf message :title) + :colorize (colorize-traits)))) + +;;;; view topic + +(restas:define-route view-topic ("thread/:topic-id") + (:sift-variables (topic-id 'integer)) + (view-topic-page topic-id 1)) + + +;;;; view-reply + +(restas:define-route view-reply ("messages/:reply-id") + (:sift-variables (:reply-id 'integer)) + (multiple-value-bind (pos topic-id) (storage-reply-position *storage* reply-id) + (unless topic-id + (return-from view-reply hunchentoot:+http-not-found+)) + (let ((page (ceiling pos + *max-reply-on-page*))) + (hunchentoot:redirect + (format nil + "~A#comment-~A" + (if (= page 1) + (restas:genurl 'view-topic + :topic-id topic-id) + (restas:genurl 'view-topic-page + :topic-id topic-id + :page-id page)) + reply-id))))) + +;;;; create reply on message + +(restas:define-route create-reply ("messages/reply/:message-id") + (:sift-variables (:message-id 'integer)) + (:requirement 'user-name) + (declare (ignore message-id)) + ) + +(restas:define-route create-reply/post ("messages/reply/:message-id" :method :post) + (:sift-variables (message-id 'integer)) + (:requirement 'user-name) + (let ((body (hunchentoot:post-parameter "body"))) + (when (string= body "") + (view-reply message-id)) + (view-reply (storage-create-reply *storage* + message-id + body + (user-name))))) + +;;;; delete reply + +(restas:define-route delete-message ("message/delete/:(reply-id)") + (:requirement 'user-name) + (if (storage-admin-p *storage* (user-name)) + (restas:redirect 'view-topic + :topic-id (storage-delete-reply *storage* reply-id)) + hunchentoot:+http-forbidden+)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; RSS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-rss-items (items) + (iter (for item in items) + (collect (list* :href (restas:genurl* 'view-reply :reply-id (getf item :id)) + item)))) + +(defun make-rss-feed (feed) + (let ((title (getf feed :title)) + (description (getf feed :description)) + (link (getf feed :link)) + (messages (getf feed :messages))) + #|------------------------------------------------------------------------|# + (xtree:with-parse-document(doc "") + #|----------------------------------------------------------------------|# + (let ((channel (xtree:make-child-element (xtree:root doc) "channel"))) + #|--------------------------------------------------------------------|# + (setf (xtree:text-content (xtree:make-child-element channel "title")) title + (xtree:text-content (xtree:make-child-element channel "link")) link + (xtree:text-content (xtree:make-child-element channel "description")) description) + #|--------------------------------------------------------------------|# + (iter (for message in messages) + (let ((item (xtree:make-child-element channel "item"))) + (setf (xtree:text-content (xtree:make-child-element item "title")) (xtree:encode-special-chars doc (format nil "~A: ~A" (getf message :author) (getf message :title))) + (xtree:text-content (xtree:make-child-element item "link")) (xtree:encode-special-chars doc (getf message :href)) + (xtree:text-content (xtree:make-child-element item "description")) (xtree:encode-special-chars doc (getf message :message)) + (xtree:text-content (xtree:make-child-element item "pubDate")) (xtree:encode-special-chars doc (getf message :date)))))) + #|----------------------------------------------------------------------|# + (xtree:serialize doc :to-string)))) + +(restas:define-route all-forums-rss ("rss/all.rss" :content-type "application/rss+xml") + (:render-method 'make-rss-feed) + #|--------------------------------------------------------------------------|# + (let ((title (format nil "~A: Форумы" (site-name)))) + (list :title title + :description title + :link (restas:genurl* 'list-forums) + :messages (make-rss-items (storage-all-news *storage* *rss-item-count*))))) + +(restas:define-route forum-rss ("rss/:(forum-id).rss" :content-type "application/rss+xml") + (:render-method 'make-rss-feed) + #|--------------------------------------------------------------------------|# + (let ((title (format nil + "~A: Форум - ~A" + (site-name) + (first (storage-forum-info *storage* forum-id))))) + (list :title title + :description title + :link (restas:genurl* 'list-topics :forum-id forum-id) + :messages (make-rss-items (storage-forum-news *storage* forum-id *rss-item-count*))))) + +(restas:define-route topic-rss ("rss/threads/:(topic-id).rss" :content-type "application/rss+xml") + (:sift-variables (topic-id 'integer)) + (:render-method 'make-rss-feed) + #|--------------------------------------------------------------------------|# + (let ((message (storage-topic-message *storage* topic-id))) + (list :title (format nil + "~A: ~A" + (site-name) + (getf message :title)) + :description (getf message :body) + :link (restas:genurl* 'view-topic :topic-id topic-id) + :messages (make-rss-items (storage-topic-news *storage* topic-id *rss-item-count*))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Colorize +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(restas:define-route colorize-code ("colorize" :method :post) + (:render-method 'identity) + (let ((code (hunchentoot:post-parameter "code")) + (lang (hunchentoot:post-parameter "lang"))) + (colorize::html-colorization (or (find-symbol lang :keyword) + (error "Unknow coloring type: ~A" lang)) + code))) + + diff --git a/src/forum/forum.tmpl b/src/forum/forum.tmpl new file mode 100644 index 0000000..5f038cd --- /dev/null +++ b/src/forum/forum.tmpl @@ -0,0 +1,285 @@ +// -*- mode: closure-template-html -*- +// forum.tmpl +// +// This file is part of the restas-forum library, released under Lisp-LGPL. +// See file COPYING for details. +// +// Author: Moskvitin Andrey + +{namespace rulisp.forum.view} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * list all forums + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template list-forums} +
+ RSS +
+ + {foreach $forum in $forums} +
+ {$forum.title} +
+ {/foreach} +{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * list forum topics + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template nav-panel} +
+ {if $hrefAfter}« Позже{/if} + Темы {$first} - + {min($first + length($topics) - 1, $totalCount)} + из {$totalCount} + {if $hrefBefore}Раньше »{/if} +
+{/template} + +{template list-topics} +
+ RSS + + +
+ + {call nav-panel data="all" /} + +
+ {foreach $topic in $topics} +
+ {if $topic.hrefDelete}Удалить{/if} + {$topic.title != '' ? $topic.title : '*notitle*'} + {if length($topic.pages) > 1} + (стр. + {foreach $page in $topic.pages} + {if not(isFirst($page))} + {$page.number}{nil} + {if isLast($page)}){/if} + {/if} + {/foreach} + {/if} + +
+ + Автор: {$topic.author} - {$topic.createDate}
+ Сообщений: {$topic.messageCount} + {if $topic.lastAuthor} +
+ Последнее: {$topic.lastAuthor} - {$topic.lastDate} + {/if} + +
+
+ {/foreach} +
+ + {call nav-panel data="all" /} + + {if $canCreateNewTopic} + + + + + {call insertCodeDialog data="$colorize" /} + {/if} +{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * view-topic + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template view-topic} + {call view-topic-page data="all" /} +{/template} + +{template topic-pages-navigation} +
+ {if length($pages) > 1} + Страницы: + {foreach $page in $pages} + {if not($page.current)} + {$page.number} + {else} + {$page.number} + {/if} + {/foreach} + {/if} +
+{/template} + +{template view-topic-page} +
+
+ RSS + +
+ +
+
+ {$message.title} +
+
+ + {$message.author} + - {$message.created}, Сообщений - {$message.countReplies} + +
+ +
+ {$message.body |noAutoescape} +
+ + {if $canCreateMessage} +
+ Ответить +
+ {/if} +
+ + {call topic-pages-navigation} + {param pages: $pages /} + {/call} + + {foreach $reply in $replies} +
+
+ {if $reply.hrefDelete} + Удалить + {/if} + [#] + + {if $reply.prevMsg} + Ответ на + комментарий + от {$reply.prevMsg.author} {$reply.prevMsg.created} + {/if} +
+ +
+ {$reply.body |noAutoescape} +
+ + +
+ + {$reply.author} + - {$reply.date} + + + {if $canCreateMessage} + Ответить + {/if} +
+
+ {/foreach} + + {call topic-pages-navigation} + {param pages: $pages /} + {/call} +
+ + {if $canCreateMessage} + + + {call insertCodeDialog data="$colorize" /} + {/if} +{/template} + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * create-reply + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template create-reply} + Извините, этот функционал ещё не реализован. +{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * rss + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template rss-feed} + {nil}{\n} + + + {$title} + {$link} + {$description} + + {foreach $item in $messages} + + {$item.author}: {$item.title} + {$item.href} + {$item.message} + {$item.date} + + {/foreach} + + +{/template} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Insert code dialog + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +{template insertCodeDialog} +
+ +
+ +
+
+ + + +
+{/template} diff --git a/src/forum/storage.lisp b/src/forum/storage.lisp new file mode 100644 index 0000000..dab9c17 --- /dev/null +++ b/src/forum/storage.lisp @@ -0,0 +1,103 @@ +;;;; storage.lisp +;;;; +;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + +(in-package #:rulisp.forum) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; storage generic interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric storage-admin-p (storage user) + (:documentation "Return T if USER is forum admin") + (:method (storage user) + nil)) + +(defgeneric storage-list-forums (storage) + (:documentation "Returns a list of forums") + (:method (storage) + (error "#'storage-list-forums not implemented"))) + +(defgeneric storage-list-topics (storage forum limit offset) + (:documentation "Returns a list of topics is starting from a position + of 'offset and not more than 'limit") + (:method (storage forum limit offset) + (error "#'storage-list-topics not implemented"))) + +(defgeneric storage-create-topic (storage forum title body user) + (:documentation "Create new forum topic") + (:method (storage forum title body user) + (error "#'storage-create-topic not implemented"))) + +(defgeneric storage-delete-topic (storage topic) + (:documentation "Delete topic") + (:method (storage topic) + (error "#'storage-delete-topic not implemented"))) + +(defgeneric storage-forum-info (storage forum) + (:method (storage forum) + (error "#'storage-forum-info not implemented"))) + +(defgeneric storage-topic-message (storage topic) + (:method (storage topic) + (error "#'storage-list-messages not implemented"))) + +(defgeneric storage-topic-reply-count (storage topic) + (:method (storage topic) + (error "#'storage-topic-reply-count not implemented"))) + +(defgeneric storage-topic-replies (storage topic limit offset) + (:method (storage topic limit offset) + (error "#'storage-topic-replies not implemented"))) + +(defgeneric storage-create-reply (storage reply-on body user) + (:documentation "Create new reply") + (:method (storage topic body user) + (error "#'storage-create-reply not implemented"))) + +(defgeneric storage-delete-reply (storage reply) + (:documentation "Delete reply") + (:method (storage reply) + (error "#'stroage-delete-reply not implemented"))) + +(defgeneric storage-reply-position (storage reply) + (:documentation "Return position reply in topic") + (:method (storage reply) + (error "#'storage-reply-position not implemented"))) + +(defgeneric storage-all-news (storage limit) + (:documentation "Return all new message") + (:method (storage limit) + (error "#'storage-all-news not implemented"))) + +(defgeneric storage-forum-news (storage forum limit) + (:documentation "Return all new messages on one forum") + (:method (storage forum limit) + (error "#'storage-forum-news not implemented"))) + +(defgeneric storage-topic-news (storage topic limit) + (:documentation "Return all new messages on one topic") + (:method (storage topic limit) + (error "#'storage-topic-news not implemented"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; implementation in-memory storage +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass memory-storage () + ()) + +(defmethod storage-list-forums ((storage memory-storage)) + '(("common-lisp" "Common Lisp") + ("rulisp" "Обсуждение проекта"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; set default value for *storage* +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(setf *storage* + (make-instance 'memory-storage)) diff --git a/src/packages.lisp b/src/packages.lisp index 223d3f8..2c63a37 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -102,3 +102,31 @@ #:render-route-data #:colorize #:colorize-langs)) + + +(restas:define-module #:rulisp.forum + (:use #:cl #:iter) + (:export #:*storage* + #:*site-name* + #:*finalize-page* + #:*max-topic-on-page* + #:*max-reply-on-page* + #:*user-name-function* + #:*rss-item-count* + + ;; storage interface + #:storage-admin-p + #:storage-list-forums + #:storage-list-topics + #:storage-create-topic + #:storage-delete-topic + #:storage-forum-info + #:storage-topic-message + #:storage-topic-reply-count + #:storage-topic-replies + #:storage-create-reply + #:storage-delete-reply + #:storage-reply-position + #:storage-all-news + #:storage-forum-news + #:storage-topic-news)) diff --git a/src/rulisp.lisp b/src/rulisp.lisp index c2f806c..0766287 100644 --- a/src/rulisp.lisp +++ b/src/rulisp.lisp @@ -105,18 +105,18 @@ ;;;; forum -(restas:mount-module -forum- (#:restas.forum) +(restas:mount-module -forum- (#:rulisp.forum) (:url "forum") (:render-method (lambda (obj) (rulisp-finalize-page :title (getf obj :title) - :content (restas:render-object (find-package '#:restas.forum.view) + :content (restas:render-object (find-package '#:rulisp.forum.view) obj) :css '("style.css" "jquery.wysiwyg.css" "forum.css" "colorize.css" ) :js (getf obj :js)))) - (restas.forum:*site-name* "Lisper.ru") - (restas.forum:*storage* *rulisp-db-storage*) - (restas.forum:*user-name-function* #'compute-user-login-name)) + (rulisp.forum:*site-name* "Lisper.ru") + (rulisp.forum:*storage* *rulisp-db-storage*) + (rulisp.forum:*user-name-function* #'compute-user-login-name)) ;;;; format diff --git a/src/storage.lisp b/src/storage.lisp index d825a02..c57d01e 100644 --- a/src/storage.lisp +++ b/src/storage.lisp @@ -134,13 +134,13 @@ ;;;; storage-admin-p -(defmethod restas.forum:storage-admin-p ((storage rulisp-db-storage) user) +(defmethod rulisp.forum:storage-admin-p ((storage rulisp-db-storage) user) (member user '("archimag" "lispnik" "turtle") :test #'string=)) ;;;; storage-list-forums -(defmethod restas.forum:storage-list-forums ((storage rulisp-db-storage)) +(defmethod rulisp.forum:storage-list-forums ((storage rulisp-db-storage)) (with-db-storage storage (postmodern:query (:order-by (:select 'pretty-forum-id 'description @@ -164,7 +164,7 @@ ORDER BY COALESCE(m.created, fm.created) DESC LIMIT $3 OFFSET $2") -(defmethod restas.forum:storage-list-topics ((storage rulisp-db-storage) forum limit offset) +(defmethod rulisp.forum:storage-list-topics ((storage rulisp-db-storage) forum limit offset) (with-db-storage storage (iter (for (author title created id message-count last-author last-date first-author) in (select-topics* forum offset limit)) (collect (list :author author @@ -177,13 +177,13 @@ ;;; storage-create-topic -(defmethod restas.forum:storage-create-topic ((storage rulisp-db-storage) forum-id title body user) +(defmethod rulisp.forum:storage-create-topic ((storage rulisp-db-storage) forum-id title body user) (with-db-storage storage (postmodern:query (:select (:rlf-new-topic forum-id title body user))))) ;;; storage-delete-topic -(defmethod restas.forum:storage-delete-topic ((storage rulisp-db-storage) topic) +(defmethod rulisp.forum:storage-delete-topic ((storage rulisp-db-storage) topic) (with-db-storage storage (let ((forum-id (postmodern:query (:select '* :from (:rlf_delete_topic topic)) :single))) @@ -193,7 +193,7 @@ ;;;; storage-form-info -(defmethod restas.forum:storage-forum-info ((storage rulisp-db-storage) forum) +(defmethod rulisp.forum:storage-forum-info ((storage rulisp-db-storage) forum) (with-db-storage storage (postmodern:query (:select 'description 'all-topics :from 'rlf-forums @@ -202,7 +202,7 @@ ;;;; storage-topic-message -(defmethod restas.forum:storage-topic-message ((storage rulisp-db-storage) topic-id) +(defmethod rulisp.forum:storage-topic-message ((storage rulisp-db-storage) topic-id) (with-db-storage storage (bind:bind (((title id message-id all-message author body created) (postmodern:query (:select (:dot :t 'title) @@ -235,7 +235,7 @@ ;;;; storage-topic-reply-count -(defmethod restas.forum:storage-topic-reply-count ((storage rulisp-db-storage) topic) +(defmethod rulisp.forum:storage-topic-reply-count ((storage rulisp-db-storage) topic) (with-db-storage storage (postmodern:query (:select (:count '*) :from 'rlf-messages :where (:= 'topic-id topic)) @@ -243,7 +243,7 @@ ;;;; storage-topic-replies -(defmethod restas.forum:storage-topic-replies ((storage rulisp-db-storage) topic limit offset) +(defmethod rulisp.forum:storage-topic-replies ((storage rulisp-db-storage) topic limit offset) (with-db-storage storage (postmodern:query (:limit (:order-by @@ -266,7 +266,7 @@ ;;;; storage-create-reply -(defmethod restas.forum:storage-create-reply ((storage rulisp-db-storage) reply-on body user) +(defmethod rulisp.forum:storage-create-reply ((storage rulisp-db-storage) reply-on body user) (with-db-storage storage (let ((message-id (postmodern:query (:select (:nextval "rlf_messages_message_id_seq")) :single))) @@ -281,7 +281,7 @@ ;;;; storage-delete-reply -(defmethod restas.forum:storage-delete-reply ((storage rulisp-db-storage) reply) +(defmethod rulisp.forum:storage-delete-reply ((storage rulisp-db-storage) reply) (let ((topic-id (with-db-storage storage (postmodern:query (:select '* :from (:rlf_delete_message reply)) :single)))) @@ -291,7 +291,7 @@ ;;;; storage-reply-position -(defmethod restas.forum:storage-reply-position ((storage rulisp-db-storage) reply) +(defmethod rulisp.forum:storage-reply-position ((storage rulisp-db-storage) reply) (with-db-storage storage (let ((topic-id (postmodern:query (:select 'topic-id :from 'rlf-messages :where (:= 'message-id reply)) @@ -329,15 +329,15 @@ ,limit) :plists))) -(defmethod restas.forum:storage-all-news ((storage rulisp-db-storage) limit) +(defmethod rulisp.forum:storage-all-news ((storage rulisp-db-storage) limit) (new-messages nil limit)) -(defmethod restas.forum:storage-forum-news ((storage rulisp-db-storage) forum limit) +(defmethod rulisp.forum:storage-forum-news ((storage rulisp-db-storage) forum limit) (new-messages (:= (:dot :f 'pretty-forum-id) forum) limit)) -(defmethod restas.forum:storage-topic-news ((storage rulisp-db-storage) topic limit) +(defmethod rulisp.forum:storage-topic-news ((storage rulisp-db-storage) topic limit) (new-messages (:= (:dot :m 'topic-id) topic) limit)) From 5e5b8c711f52ae2b54c2b87d5cc6230a53060843 Mon Sep 17 00:00:00 2001 From: Hedin Date: Thu, 29 Mar 2018 09:47:15 +0300 Subject: [PATCH 6/7] Fix file headers --- src/colorize/defmodule.lisp | 2 +- src/colorize/drawer.lisp | 2 +- src/colorize/drawer.tmpl | 2 +- src/colorize/routes.lisp | 2 +- src/colorize/storage.lisp | 2 +- src/forum/defmodule.lisp | 4 ++-- src/forum/forum.lisp | 2 +- src/forum/forum.tmpl | 2 +- src/forum/storage.lisp | 2 +- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/colorize/defmodule.lisp b/src/colorize/defmodule.lisp index 7e05581..3ef93d9 100644 --- a/src/colorize/defmodule.lisp +++ b/src/colorize/defmodule.lisp @@ -1,6 +1,6 @@ ;;;; packages.lisp ;;;; -;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/colorize/drawer.lisp b/src/colorize/drawer.lisp index f2e78d4..049aaf9 100644 --- a/src/colorize/drawer.lisp +++ b/src/colorize/drawer.lisp @@ -1,6 +1,6 @@ ;;;; drawer.lisp ;;;; -;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/colorize/drawer.tmpl b/src/colorize/drawer.tmpl index 49a2f08..89f7afe 100644 --- a/src/colorize/drawer.tmpl +++ b/src/colorize/drawer.tmpl @@ -1,7 +1,7 @@ // -*- mode: closure-template-html -*- // colorize.tmpl // -// This file is part of the restas-colorize library, released under Lisp-LGPL. +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 // See file COPYING for details. // // Author: Moskvitin Andrey diff --git a/src/colorize/routes.lisp b/src/colorize/routes.lisp index 93432bb..9f8e983 100644 --- a/src/colorize/routes.lisp +++ b/src/colorize/routes.lisp @@ -1,6 +1,6 @@ ;;;; colorize.lisp ;;;; -;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/colorize/storage.lisp b/src/colorize/storage.lisp index a0f6475..dbeee43 100644 --- a/src/colorize/storage.lisp +++ b/src/colorize/storage.lisp @@ -1,6 +1,6 @@ ;;;; storage.lisp ;;;; -;;;; This file is part of the restas-colorize library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/forum/defmodule.lisp b/src/forum/defmodule.lisp index 0629d4f..9d10023 100644 --- a/src/forum/defmodule.lisp +++ b/src/forum/defmodule.lisp @@ -1,6 +1,6 @@ -;;;; packages.lisp +;;;; defmodule.lisp ;;;; -;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/forum/forum.lisp b/src/forum/forum.lisp index 79c48f1..0b09e16 100644 --- a/src/forum/forum.lisp +++ b/src/forum/forum.lisp @@ -1,6 +1,6 @@ ;;;; forum.lisp ;;;; -;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey diff --git a/src/forum/forum.tmpl b/src/forum/forum.tmpl index 5f038cd..62660a7 100644 --- a/src/forum/forum.tmpl +++ b/src/forum/forum.tmpl @@ -1,7 +1,7 @@ // -*- mode: closure-template-html -*- // forum.tmpl // -// This file is part of the restas-forum library, released under Lisp-LGPL. +// This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 // See file COPYING for details. // // Author: Moskvitin Andrey diff --git a/src/forum/storage.lisp b/src/forum/storage.lisp index dab9c17..725c161 100644 --- a/src/forum/storage.lisp +++ b/src/forum/storage.lisp @@ -1,6 +1,6 @@ ;;;; storage.lisp ;;;; -;;;; This file is part of the restas-forum library, released under Lisp-LGPL. +;;;; This file is part of the rulisp application, released under GNU Affero General Public License, Version 3.0 ;;;; See file COPYING for details. ;;;; ;;;; Author: Moskvitin Andrey From 930dda7a0e01e40123ff68835f928d56af872776 Mon Sep 17 00:00:00 2001 From: Hedin Date: Thu, 29 Mar 2018 21:44:21 +0300 Subject: [PATCH 7/7] Merge wiki-parser into rulisp --- rulisp.asd | 13 +- src/packages.lisp | 10 ++ src/wiki-parser/dokuwiki.lisp | 287 ++++++++++++++++++++++++++++++++++ src/wiki-parser/parser.lisp | 261 +++++++++++++++++++++++++++++++ 4 files changed, 568 insertions(+), 3 deletions(-) create mode 100644 src/wiki-parser/dokuwiki.lisp create mode 100644 src/wiki-parser/parser.lisp diff --git a/rulisp.asd b/rulisp.asd index 8262c6e..8c05e19 100644 --- a/rulisp.asd +++ b/rulisp.asd @@ -15,7 +15,6 @@ #:restas-directory-publisher #:xfactory #:cl-typesetting - #:wiki-parser #:net-telent-date #:local-time #:clon @@ -23,14 +22,17 @@ #:cl-libxml2 #:babel #:colorize - #:metabang-bind) + #:metabang-bind + #:iterate + #:alexandria + #:cl-ppcre) :defsystem-depends-on (#:closure-template) :components ((:file "pref") (:module :src :components ((:file "packages") (:module "dokuwiki" :components ((:file "render-html")) - :depends-on ("packages" "wiki")) + :depends-on ("packages" "wiki" "wiki-parser")) (:module "auth" :components ((:module "templates" :components ((:closure-template "forgot") @@ -65,6 +67,11 @@ (:file "storage" :depends-on ("defmodule")) (:file "forum" :depends-on ("storage"))) :depends-on ("packages")) + + (:module "wiki-parser" + :components ((:file "parser") + (:file "dokuwiki" :depends-on ("parser"))) + :depends-on ("packages")) (:file "storage" :depends-on ("packages")) (:file "pcl" :depends-on ("rulisp")) (:file "jscl" :depends-on ("rulisp")) diff --git a/src/packages.lisp b/src/packages.lisp index 2c63a37..bfd4136 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -130,3 +130,13 @@ #:storage-all-news #:storage-forum-news #:storage-topic-news)) + +(defpackage #:wiki-parser + (:use #:cl #:iter) + (:export #:parse + #:remake-lexer + #:define-parser + #:define-toplevel-mode + #:define-mode + #:bad-element-condition + #:init-parser)) diff --git a/src/wiki-parser/dokuwiki.lisp b/src/wiki-parser/dokuwiki.lisp new file mode 100644 index 0000000..63b0888 --- /dev/null +++ b/src/wiki-parser/dokuwiki.lisp @@ -0,0 +1,287 @@ +;;;; dokuwiki.lisp +;;;; +;;;; This file is part of the wiki-parser library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + + +(defpackage #:wiki-parser.dokuwiki + (:use #:cl #:iter) + (:nicknames #:dokuwiki) + (:import-from #:wiki-parser #:define-mode #:remake-lexer) + (:export #:chapter + #:paragraph)) + +(in-package #:wiki-parser.dokuwiki) + +(defparameter *lexer* nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *symbols-category* (make-hash-table))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; dokuwiki + +(define-mode toplevel (0) + (:allowed :container :baseonly :paragraphs :formatting :substition :protected :disabled)) + +(define-mode footnote (150 :formatting) + (:allowed :container :formatting :substition :protected :disabled) + (:not-allowed footnote) + (:entry "\\(\\((?=.*\\)\\))") + (:exit "\\)\\)")) + +(define-mode header (50 :baseonly) + (:special "[ \\t]*={2,}[^\\n]+={2,}[ \\t]*(?=\\n)")) + +(define-mode notoc (30 :substition) + (:single "~~NOTOC~~")) + +(define-mode nocache (40 :substition) + (:single "~~NOCACHE~~")) + +(define-mode linebreak (140 :substition) + (:single "\\\\\\\\")) + ;;(:single "\\\\\\\\(?=\\s)")) + +(define-mode eol (370 :paragraphs) + (:single "\\n")) + +(define-mode hr (160 :container) + (:single "\\n[ \\t]*-{4,}[ \\t]*(?=\\n)")) + +(define-mode strong (70 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed strong) + (:entry "\\*\\*(?=.*\\*\\*)") + (:exit "\\*\\*")) + +(define-mode emphasis (80 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed emphasis) + (:entry "//(?=.*//)") + (:exit "//")) + +(define-mode underline (90 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed underline) + (:entry "__(?=.*__)") + (:exit "__")) + +(define-mode monospace (100 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed monospace) + (:entry "''(?=.*'')") + (:exit "''")) + +(define-mode subscript (110 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed subscript) + (:entry "(?=.*)") + (:exit "")) + +(define-mode superscript (120 :formatting) + (:allowed :formatting :substition :disabled) + (:not-allowed superscript) + (:entry "(?=.*)") + (:exit "")) + +(define-mode unordered-listblock (10 :container) + (:allowed :formatting :substition :disabled :protected) + (:entry "\\n {2,}\\*" + "\\n\\t{1,}\\*") + (:exit "\\n") + (:continue "\\n {2,}\\*" + "\\n\\t{1,}\\*")) + +(define-mode ordered-listblock (10 :container) + (:allowed :formatting :substition :disabled :protected) + (:entry "\\n {2,}\\-" + "\\n\\t{1,}\\-") + (:exit "\\n") + (:continue "\\n {2,}\\-" + "\\n\\t{1,}\\-")) + +(define-mode table (60 :container) + (:allowed :table) + (:special "\\n[\\^\\|][^\\n]+[\\^\\|][^\\n]*(?=\\n)")) + +(define-mode table-header-cell (63 :table) + (:allowed :formatting :substition :disabled :protected) + (:entry "\\n?\\^(?=[^\\n]*[\\^|\\|])") + (:exit) + (:exit-border "\\^" + "\\|")) + +(define-mode table-cell (65 :table) + (:allowed :formatting :substition :disabled :protected) + (:entry "\\n?\\|(?=[^\\n]*[\\^\\|])") + (:exit-border "\\^" + "\\|")) + +(define-mode unformatted (170 :disabled) + (:entry "(?=.*)") + (:exit "")) + +(define-mode unformattedalt (171 :disabled) + (:entry "%%(?=.*%%)") + (:exit "%%")) + +(define-mode html (190 :protected) + (:entry "(?=.*)") + (:exit "")) + +(define-mode preformatted (20 :protected) + (:entry "\\n (?![\\*\\-])" + "\\n\\t(?![\\*\\-])") + (:exit "\\n") + (:continue "\\n " + "\\n\\t")) + +(define-mode code (200 :protected) + (:entry "]*>(?=.*)") + (:exit "")) + +(define-mode file (210 :protected) + (:entry "(?=.*)") + (:exit "")) + +(define-mode quoted (220 :container) + (:allowed :formatting :substition :disabled :protected footnote preformatted unformatted) + (:entry "\\n>{1,}") + (:exit "\\n") + (:continue "\\n>{1,}")) + +(define-mode internal-link (300 :substition) + (:entry "\\[\\[(?=.*\\]\\])") + (:exit "\\]\\]")) + +(define-mode media (320 :substition) + (:entry "{{(?=.*}})") + (:exit "}}")) + +(define-mode external-link (330 :substition) + (:special "(?:ht|f)tp(?:s?)://[0-9a-zA-Z](?:[-.\\w]*[0-9a-zA-Z])*(?::(?:0-9)*)*(?:/?)(?:[a-zA-Z0-9\\-\\.\\?\\,/\\+&%\\$#\\*]*)?")) + +(define-mode em-dash (340 :substition) + (:single "---")) + +(define-mode en-dash (350 :substition) + (:single "--")) + + +;;; remake lexer + +(remake-lexer 'toplevel) + + +;;; make-chapter-tree + +(defun header-level (header) + (let ((str (string-trim #(#\Space #\Tab) (second header)))) + (min (position #\= str :test-not #'char-equal) + (- (length str) + (position #\= str :test-not #'char-equal :from-end t) + 1)))) + +(defun header-strim (header) + (let* ((str (string-trim #(#\Space #\Tab) (second header))) + (n (min (position #\= str :test-not #'char-equal) + (- (length str) + (position #\= str :test-not #'char-equal :from-end t) + 1)))) + (list (car header) + (string-trim #(#\Space #\Tab) + (subseq str n (- (length str) n)))))) + +(defun make-chapter-tree (wikidoc &optional (end nil)) + (let ((marks) + (level)) + (iter (for tail on wikidoc) + (while (not (eql tail end))) + (let ((item (car tail))) + (when (and (consp item) + (eq (car item) 'header) + (>= (header-level item) + (or level 0))) + (push tail marks) + (unless level + (setf level + (header-level item)))))) + (setf marks (nreverse marks)) + (concatenate 'list + (ldiff wikidoc (or (car marks) end)) + (iter (for m on marks) + (collect (list* 'chapter + (header-strim (caar m)) + (make-chapter-tree (cdr (first m)) + (or (second m) end)))))))) + + +;;;; union-same-items + +(defparameter *union-same-items* '(preformatted unordered-listblock ordered-listblock quoted table)) + +(defun union-same-items (wikidoc) + (let ((result nil)) + (iter (for item in wikidoc) + (cond + ((atom item) (push item result)) + ((and (consp (car result)) + (find (car item) + *union-same-items*) + (eql (car item) + (caar result))) (nconc (car result) + (if (third item) + (list (union-same-items (cdr item))) + (union-same-items (cdr item)))) + ) + ((find (car item) + *union-same-items*) (push (cons (car item) + (if (third item) + (list (union-same-items (cdr item))) + (cdr (union-same-items item)))) + result)) + (t (push (union-same-items item) + result)))) + (nreverse result))) + +;;;; make-paragraphs + +(defun make-paragraphs (wikidoc) + (let ((result nil)) + (flet ((paragraph-part-p (item) + (or (stringp item) + (and (symbolp item) + (eql (gethash item *symbols-category*) + :substition)) + (and (consp item) + (find (gethash (car item) + *symbols-category*) + '(:formatting :substition))))) + (append-to-last-paragraph (item) + (nconc (car result) + (list item)))) + (iter (for item in wikidoc) + (cond + ((paragraph-part-p item) (if (and (consp (car result)) + (eql (caar result) 'paragraph)) + (append-to-last-paragraph item) + (push (list 'paragraph item) + result))) + ((and (eql item 'eol) + (consp (car result)) + (eql (caar result) 'paragraph) + (not (eql (car (last (car result))) 'eol))) (append-to-last-paragraph item)) + (t (push item result)))) + (nreverse result)))) + +;;;; wiki-parser:parse + +(defmethod wiki-parser:parse ((markup (eql :dokuwiki)) (obj string)) + (make-chapter-tree + (make-paragraphs + (union-same-items + (call-next-method))))) diff --git a/src/wiki-parser/parser.lisp b/src/wiki-parser/parser.lisp new file mode 100644 index 0000000..b88840c --- /dev/null +++ b/src/wiki-parser/parser.lisp @@ -0,0 +1,261 @@ +;;;; parser.lisp +;;;; +;;;; This file is part of the wiki-parser library, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Moskvitin Andrey + + +(in-package #:wiki-parser) + +(defparameter +lexer-symbol+ "*LEXER*") +(defparameter +symbols-category-symbol+ "*SYMBOLS-CATEGORY*") +(defparameter +toplevel-symbol+ "TOPLEVEL") + +(defun string-symbol-value (string &optional (package *package*)) + (symbol-value (find-symbol string package))) + +(defun symbols-category-hash (symbol) + (string-symbol-value +symbols-category-symbol+ + (symbol-package symbol))) + +(defun allowed-modes (mode) + (labels ((expand-modes (modes) + (cond + ((null modes) nil) + ((keywordp (car modes)) + (concatenate 'list + (iter (for (key value) in-hashtable (symbols-category-hash mode)) + (when (eql value (car modes)) + (collect key))) + (expand-modes (cdr modes)))) + ((symbolp (car modes)) + (cons (car modes) + (expand-modes (cdr modes)))) + (t (error "bad mode: ~A" (car modes)))))) + (sort (set-difference (expand-modes (get mode :allowed)) + (expand-modes (get mode :not-allowed))) + #'< + :key #'(lambda (s) (get s :sort))))) + +(defun parse-regex (re) + (cond + ((stringp re) (ppcre:parse-string re)) + ((consp re) re) + (t (error "Bad type of regular expressiong: ~A" re)))) + +(defun make-mtable (mode) + (let ((regexs nil) + (modes nil)) + (iter (for exit in (get mode :continue)) + (push :continue modes) + (push (parse-regex exit) regexs)) + (iter (for exit in (get mode :exit)) + (push :exit modes) + (push (parse-regex exit) regexs)) + (iter (for reg in (get mode :exit-border)) + (push :exit-border modes) + (push (parse-regex reg) regexs)) + (iter (for amode in (allowed-modes mode)) + (iter (for entry in (get amode :entry)) + (push amode modes) + (push (parse-regex entry) regexs)) + (iter (for special in (get amode :special)) + (push (cons :special amode) modes) + (push (parse-regex special) regexs)) + (iter (for single in (get amode :single)) + (push (cons :single amode) modes) + (push (parse-regex single) regexs))) + (cons (if (cdr regexs) + (cons :alternation + (iter (for reg in (nreverse regexs)) + (collect (list :register reg)))) + (list :register (car regexs))) + (coerce (nreverse modes) 'vector)))) + +(defun mtable-regex (mtable) + (car mtable)) + +(defun mtable-modes (mtable) + (cdr mtable)) + +(defun mtable-scan (mtable target-string &key (start 0) (end (length target-string))) + (multiple-value-bind (pos1 pos2 arr1) + (ppcre:scan (ppcre:create-scanner (mtable-regex mtable) + :single-line-mode :MULTI-LINE-MODE-P) + target-string + :start start + :end end) + (if pos1 + (let ((index (position-if #'identity arr1))) + (values (aref (mtable-modes mtable) + index) + pos1 + pos2))))) + +(defun fill-lexer (lexer mode) + (unless (gethash mode lexer) + (setf (gethash mode lexer) + (make-mtable mode)) + (map 'nil + (alexandria:curry #'fill-lexer lexer) + (allowed-modes mode))) + lexer) + +(defun make-lexer (mode) + (fill-lexer (make-hash-table) mode)) + +(defun remake-lexer (mode) + (let ((package (symbol-package mode))) + (setf (symbol-value (find-symbol +lexer-symbol+ package)) + (make-lexer (find-symbol +toplevel-symbol+ package))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-condition bad-element-condition (error) ()) + +(defun apply-post-handler (expr) + (let ((post-handler (if (and (consp expr) + (symbolp (car expr))) + (car (get (car expr) :post-handler))))) + (if post-handler + (funcall post-handler expr) + expr))) + +(defun lexer-parse/impl (mode target-string &key (start 0) (end (length target-string)) lexer) + (let ((lex (or (string-symbol-value +lexer-symbol+ + (symbol-package mode)) + lexer)) + (curpos start) + (tokens (list mode)) + (continue nil)) + (iter (while (< curpos end)) + (multiple-value-bind (in-mode pos1 pos2) + (mtable-scan (gethash mode lex) + target-string + :start curpos + :end end) + (when (or (not in-mode) + (> pos1 curpos)) + (push (subseq target-string + curpos + (or pos1 end)) + tokens)) + + (setf curpos (or pos2 end)) + + (cond + ((eql in-mode :exit) (finish)) + ((eql in-mode :exit-border) + (setf curpos pos1) + (finish)) + ((eql in-mode :continue) + (setf continue t) + (finish)) + ((and (consp in-mode) + (eql (car in-mode) :special)) + (push (handler-case + (apply-post-handler (if (equal (mtable-regex (gethash (cdr in-mode) + lex)) + '(:register nil)) + (list (cdr in-mode) + (subseq target-string + pos1 + pos2)) + (lexer-parse/impl (cdr in-mode) + target-string + :start pos1 + :end pos2 + :lexer lex))) + (bad-element-condition () + (subseq target-string pos1 pos2))) + tokens)) + ((and (consp in-mode) + (eql (car in-mode) :single)) + (push (cdr in-mode) + tokens)) + (in-mode + (let ((cont t)) + (iter (while cont) + (setf cont nil) + (multiple-value-bind (item pos continue) + (lexer-parse/impl in-mode + target-string + :start curpos + :end end + :lexer lex) + (push (handler-case + (apply-post-handler + (let ((entry-attribute-parser (car (get in-mode :entry-attribute-parser)))) + (if entry-attribute-parser + (list* (car item) + (funcall entry-attribute-parser + (subseq target-string pos1 curpos)) + (cdr item)) + item))) + (bad-element-condition () + (subseq target-string pos1 pos))) + tokens) + (setf curpos pos) + (setf cont continue)))))))) + (values (nreverse tokens) + curpos + continue))) + +(defun lexer-parse (mode target-string) + (lexer-parse/impl mode + (format nil + "~%~A~%" + (remove #\Return target-string)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric parse (markup-type obj)) + +(defmethod parse (markup-type (path pathname)) + (parse markup-type (alexandria:read-file-into-string path))) + +(defmethod parse (markup-type (string string)) + (lexer-parse (find-symbol +toplevel-symbol+ markup-type) + string)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; define parser macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro define-parser (name &rest options) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((*package* (defpackage ,name + ,@options + (:import-from #:wiki-parser #:define-toplevel-mode #:define-mode #:remake-lexer #:init-parser)))) + (flet ((defparam (name &optional value) + (eval `(defparameter ,(intern name) ,value)))) + (defparam +lexer-symbol+ nil) + (defparam +symbols-category-symbol+ (make-hash-table)) + *package*)))) + +(defmacro define-mode (name (sort &optional category) &rest args) + `(progn + (export ',name) + (setf (get ',name :sort) + ,sort) + (setf (gethash ',name (symbols-category-hash ',name)) + ,category) + (iter (for prop in ',args) + (setf (get ',name (car prop)) + (if (and (member (car prop) '(:post-handler :entry-attribute-parser)) + (third prop)) + (list (eval `(lambda ,@(cdr prop)))) + (cdr prop)))) + (eval-when (:execute) + (remake-lexer ',name)))) + +(defmacro define-toplevel-mode (&rest options) + (let ((toplevel (intern +toplevel-symbol+ *package*))) + `(define-mode ,toplevel (0) + ,@options))) + + +(defmacro init-parser () + `(remake-lexer (find-symbol +toplevel-symbol+ *package*))) \ No newline at end of file