├── version.lisp-expr ├── weblocks-cms-pages.asd ├── README.md ├── package.lisp ├── make-route-with-static-value.lisp ├── user-template-widget.lisp ├── license.txt └── weblocks-cms-pages.lisp /version.lisp-expr: -------------------------------------------------------------------------------- 1 | "0.2.4" 2 | -------------------------------------------------------------------------------- /weblocks-cms-pages.asd: -------------------------------------------------------------------------------- 1 | ;;;; weblocks-cms-pages.asd 2 | 3 | (asdf:defsystem #:weblocks-cms-pages 4 | :serial t 5 | :description "Static pages functionality for Weblocks CMS" 6 | :author "Olexiy Zamkoviy " 7 | :version (:read-from-file "version.lisp-expr") 8 | :license "LLGPL" 9 | :depends-on (#:weblocks 10 | #:weblocks-cms 11 | #:weblocks-utils 12 | #:yaclml 13 | #:weblocks-mustache-templates-editor) 14 | :components ((:file "package") 15 | (:file "make-route-with-static-value") 16 | (:file "user-template-widget") 17 | (:file "weblocks-cms-pages"))) 18 | 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Weblocks CMS Pages plugin 2 | 3 | Contains static pages functionality for Weblocks CMS. 4 | Each page has its static url, name, title, content. 5 | Each page is a subtree of widgets, templates, etc. 6 | 7 | ## Weblocks CMS Pages backend 8 | 9 | An admin interface for pages. Allows to create/edit pages. 10 | It is included into Weblocks CMS standard admin interface, new button "Site Page" should appear after including weblocks-cms-pages package. 11 | 12 | ## Weblocks CMS Pages frontend 13 | 14 | A widget responsible for proper navigation to pages. 15 | It should be included into root widget. 16 | 17 | ## Compatibility 18 | 19 | Currently Weblocks CMS Pages works with `weblocks-routes` branch of https://github.com/html/weblocks repository 20 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:weblocks-cms-pages 4 | (:use #:cl) 5 | (:export #:pages-container 6 | #:add-page-widget #:add-page-callback #:make-template-widget 7 | #:get-variable-description #:add-default-template-widget-variable 8 | #:render-page-by-name #:get-widget-by-template-name) 9 | (:import-from :weblocks 10 | #:defwidget #:translate #:composite 11 | #:*routes-mapper* #:connect #:render-widget 12 | #:dom-id #:dom-classes #:render-widget-body 13 | #:*weblocks-output-stream* #:request-hook #:render-widget-children 14 | #:widget-children #:make-widget #:get-widgets-by-type) 15 | (:import-from :weblocks-utils #:first-by-values #:all-of)) 16 | 17 | 18 | (in-package :weblocks-cms-pages) 19 | 20 | (weblocks-cms:def-additional-schema 21 | :page 22 | `((:TITLE ,(translate "Site Page") :NAME :PAGE :FIELDS 23 | ((:TITLE ,(translate "Page Content") :NAME :CONTENT :TYPE :SINGLE-CHOICE :OPTIONS NIL) 24 | (:TITLE ,(translate "Site Path") :NAME :PATH :TYPE :STRING :OPTIONS NIL) 25 | (:TITLE ,(translate "Parent Page") :NAME :PARENT :TYPE :SINGLE-RELATION 26 | :OPTIONS NIL) 27 | (:TITLE ,(translate "Page Title") :NAME :TITLE :TYPE :STRING :OPTIONS NIL) 28 | (:TITLE ,(translate "Page Name") :NAME :NAME :TYPE :STRING :OPTIONS NIL))))) 29 | 30 | -------------------------------------------------------------------------------- /make-route-with-static-value.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks-cms-pages) 2 | 3 | (defun make-route-with-static-value (route spec value) 4 | (make-instance 5 | 'routes:route 6 | :template (list 7 | (make-instance 'routes::custom-variable-template 8 | :spec spec 9 | :parse (lambda (url) 10 | (if (string= 11 | (string-trim "/" url) 12 | (string-trim "/" route)) 13 | value 14 | "" 15 | )))))) 16 | 17 | #+l(defun make-route-with-static-value (route varspecs) 18 | (routes:make-route 19 | (apply #'concatenate 20 | (list* 'string 21 | (string-right-trim "/" route) 22 | "/" 23 | (loop for (key value) on varspecs by #'cddr 24 | collect (format nil ":(~A)" (string-downcase key))))) 25 | (loop for (key value) on varspecs by #'cddr 26 | append (list key 27 | (lambda (value-to-return &rest args) 28 | (describe value-to-return) 29 | (when (zerop (length value-to-return)) 30 | value)))))) 31 | 32 | (let ((mapper (make-instance 'weblocks::priority-generation-mapper))) 33 | (connect mapper (make-route-with-static-value "/catalog" :main-selector.selected "test")) 34 | (multiple-value-bind (route params) (routes:match mapper "/catalog") 35 | (assert (not (null route))) 36 | (assert (equal params '((:main-selector.selected . "test")))))) 37 | 38 | (let ((mapper (make-instance 'weblocks::priority-generation-mapper))) 39 | (connect mapper (make-route-with-static-value "/collections" :main-selector.selected "test")) 40 | (multiple-value-bind (route params) (routes:match mapper "/collections") 41 | (assert (not (null route))) 42 | (assert (equal params '((:main-selector.selected . "test")))))) 43 | 44 | (defclass custom-static-variable-template (routes::custom-variable-template) 45 | ((variables-values :initform nil :initarg :values))) 46 | 47 | (defclass route-with-static-variable (routes:route) 48 | ()) 49 | 50 | (defun clear-static-variables-routes-for-variable (mapper given-variable-name) 51 | (let (variable-name) 52 | (loop for (route . priority) in (slot-value mapper 'weblocks::routes) do 53 | (when (typep route 'route-with-static-variable) 54 | (setf variable-name (routes:template-data (first (slot-value route 'routes::template)))) 55 | (when (equal given-variable-name variable-name) 56 | (setf (slot-value (first (slot-value route 'routes::template)) 'variables-values) nil) 57 | (return-from clear-static-variables-routes-for-variable t)))))) 58 | 59 | (defmethod weblocks::connect ((mapper weblocks::priority-generation-mapper) (obj route-with-static-variable)) 60 | "Connects static variable route with mapper, tries to find existing route with same variable name, if found changes it, if not connects route to mapper." 61 | (flet ((merge-route-variable-values (from-route to-route) 62 | (setf 63 | (slot-value (first (slot-value to-route 'routes::template)) 'variables-values) 64 | (remove-duplicates 65 | (append 66 | (slot-value (first (slot-value from-route 'routes::template)) 'variables-values) 67 | (slot-value (first(slot-value to-route 'routes::template)) 'variables-values)) 68 | :key #'car 69 | :test #'string=)))) 70 | (let ((given-variable-name (routes:template-data (first (slot-value obj 'routes::template)))) 71 | variable-name) 72 | (loop for (route . priority) in (slot-value mapper 'weblocks::routes) do 73 | (when (typep route 'route-with-static-variable) 74 | (setf variable-name (routes:template-data (first (slot-value route 'routes::template)))) 75 | (when (equal given-variable-name variable-name) 76 | (merge-route-variable-values obj route) 77 | (return-from weblocks::connect)))) 78 | 79 | (call-next-method)))) 80 | 81 | (defun static-variable-template-parse-callback (template) 82 | (lambda (url) 83 | (loop for (key . val) in (slot-value template 'variables-values) 84 | if (string= 85 | (string-trim "/" url) 86 | (string-trim "/" key)) 87 | return val))) 88 | 89 | (defun make-routes-with-static-value (spec values) 90 | (make-instance 91 | 'route-with-static-variable 92 | :template (list 93 | (let ((template 94 | (make-instance 'custom-static-variable-template 95 | :values values 96 | :spec spec))) 97 | (setf (slot-value template 'routes::parse-fun) 98 | (static-variable-template-parse-callback template)) 99 | template)))) 100 | 101 | (let ((mapper (make-instance 'routes:mapper))) 102 | 103 | (routes:connect mapper (make-routes-with-static-value 104 | :main-selector.selected 105 | (list 106 | (cons "catalog" "catalog") 107 | (cons "collections" "collections")))) 108 | 109 | (multiple-value-bind (route params) (routes:match mapper "/catalog") 110 | (assert (not (null route))) 111 | (assert (equal params '((:main-selector.selected . "catalog"))))) 112 | 113 | (multiple-value-bind (route params) (routes:match mapper "/collections") 114 | (assert (not (null route))) 115 | (assert (equal params '((:main-selector.selected . "collections")))))) 116 | 117 | -------------------------------------------------------------------------------- /user-template-widget.lisp: -------------------------------------------------------------------------------- 1 | (in-package :weblocks-cms-pages) 2 | 3 | (defwidget user-template-widget () 4 | ((template :initarg :template :initform nil) 5 | (variables :initarg :variables :initform nil))) 6 | 7 | (defmethod dom-classes ((widget user-template-widget)) 8 | (format nil "~A user-template-~A" (call-next-method) (string-downcase (slot-value widget 'template)))) 9 | 10 | (defmethod print-object ((widget user-template-widget) stream) 11 | (if (and (slot-boundp widget 'template) 12 | (slot-boundp widget 'variables)) 13 | (with-slots (template variables) widget 14 | (print-unreadable-object (widget stream :type t :identity t) 15 | (format stream " \"~A\" template=~A ~A" 16 | (dom-id widget) 17 | (string-downcase template) 18 | (if variables 19 | (format nil "variables=~{~A~^,~}" (mapcar #'string-downcase (mapcar #'car (alexandria:plist-alist variables)))) 20 | "no variables")))) 21 | (call-next-method))) 22 | 23 | (defun replace-variables (template variables) 24 | (let ((new-vars (append-default-variables template nil))) 25 | (append 26 | (loop for (key . value) on variables by #'cddr 27 | append (list key (or 28 | (getf new-vars key) 29 | (getf variables key)))) 30 | (loop for (key . value) on new-vars by #'cddr 31 | append (unless (getf variables key) 32 | (cons key value))) 33 | (list :tr (cons 34 | (lambda (str) 35 | (weblocks::translate str)) 36 | "Функция для перевода, текст {{#tr}}Text{{/tr}} будет пропущен через переводчик"))))) 37 | 38 | (defmethod update-variables ((obj user-template-widget)) 39 | (with-slots (template variables) obj 40 | (setf variables (replace-variables template variables)))) 41 | 42 | (defmethod initialize-instance :after ((obj user-template-widget) &rest args) 43 | (update-variables obj)) 44 | 45 | (defmethod render-widget-body ((widget user-template-widget) &rest args) 46 | (with-slots (template variables) widget 47 | (let ((variables-with-widget-values 48 | (loop for (key value) on variables by #'cddr 49 | append (list key (cons (cond 50 | ((stringp (car value)) (car value)) 51 | ((arrayp (car value)) (error "Don't use arrays ! Too much complexity")) 52 | ((subtypep (type-of (car value)) 'weblocks:widget) 53 | (weblocks::capture-weblocks-output (render-widget (car value)))) 54 | (t (car value))) 55 | (cdr value)))))) 56 | (write-string 57 | (apply #'render-user-template (list* template variables-with-widget-values)) 58 | *weblocks-output-stream*)))) 59 | 60 | (defmethod render-widget-children ((widget user-template-widget) &rest args) 61 | (declare (ignore widget args))) 62 | 63 | (defmethod widget-children ((obj user-template-widget) &optional type) 64 | (with-slots (variables) obj 65 | (or 66 | (slot-value obj 'weblocks::children) 67 | (setf 68 | (slot-value obj 'weblocks::children) 69 | (loop for (key value) on variables by #'cddr 70 | append (cond 71 | ((stringp (car value)) 72 | (list (make-widget (car value)))) 73 | ((subtypep (type-of (car value)) 'weblocks:widget) 74 | (list (car value))))))))) 75 | 76 | (defun get-variables-descriptions (args) 77 | (yaclml:with-yaclml-output-to-string 78 | (loop for (first second . third) in (alexandria:plist-alist args) 79 | do 80 | (<:span 81 | (<:format "{{~A}}" (string-downcase first)) 82 | " - " 83 | (<:as-is third)) 84 | (<:br)))) 85 | 86 | (defun render-user-template (name &rest args) 87 | "Render either {name}-{current-language} template ('test-tpl-en', 'test-tpl-ru') 88 | or {name} template. If template does not exist, creates it and stores to database." 89 | (let ((wt-keyword (alexandria:make-keyword (string-upcase name))) 90 | (wt-symbol-name (intern (string-upcase name) *package*))) 91 | (weblocks-util:deftemplate wt-keyword wt-symbol-name) 92 | (weblocks-util::nested-html-part 93 | (list :type :user-template :template-name name) 94 | (let ((template-obj (or 95 | ; First searching locale file with '-en' suffix or other depending on current-locale 96 | (first-by-values 'weblocks-cms::template 97 | :name (cons (string-downcase (format nil "~A-~A" name (weblocks::current-locale))) #'string=)) 98 | ; Then searching for file itself without siffixes 99 | (first-by-values 'weblocks-cms::template 100 | :name (cons (string-downcase name) #'string=)) 101 | ; Then creating if not found 102 | (weblocks:persist-object weblocks-stores:*default-store* 103 | (make-instance 'weblocks-cms::template :name (string-downcase name)))))) 104 | (eval 105 | `(defun ,wt-symbol-name (&rest args) 106 | (mustache:render* 107 | ,(or (slot-value template-obj 'weblocks-cms::text) "") 108 | (loop for (first second) on args by #'cddr 109 | collect (cons first second))))) 110 | (prog1 111 | (eval 112 | `(apply 113 | #'weblocks-util:render-wt-to-string 114 | (list* ,wt-keyword nil 115 | '( ,@(loop for (first second . third) 116 | in (alexandria:plist-alist args) 117 | append (list first second)))))) 118 | (setf (slot-value template-obj 'weblocks-cms::variables-descriptions) 119 | (get-variables-descriptions args)) 120 | (setf (slot-value template-obj 'weblocks-cms::last-used-time) (get-universal-time))))))) 121 | 122 | (defvar *template-widget-variables* nil) 123 | 124 | (defun add-default-template-widget-variable (template-name variable-name variable-description &optional callback) 125 | (setf *template-widget-variables* 126 | (remove-if 127 | (lambda (item) 128 | (and (equal (first item) template-name) 129 | (equal (second item) variable-name))) 130 | *template-widget-variables*)) 131 | (push (list template-name variable-name variable-description callback) *template-widget-variables*)) 132 | 133 | (defun append-default-variables (template vars) 134 | (append 135 | (loop for (template-name variable-name variable-description callback) in *template-widget-variables* 136 | if (or 137 | (equal template-name template) 138 | (progn 139 | (string= (string-downcase (format nil "~A-~A" template-name (weblocks::current-locale))) 140 | (string-downcase template)))) 141 | append (list variable-name 142 | (cons 143 | (when callback 144 | (weblocks::timing (format nil "getting variable for template ~A ~A" template variable-name) 145 | (funcall callback))) variable-description))) 146 | vars)) 147 | 148 | (defun get-variable-description (template variable) 149 | "Returns description for given template and variable" 150 | (loop for (template-name variable-name variable-description callback) in *template-widget-variables* 151 | if (and (equal template-name template) 152 | (equal variable variable-name)) 153 | do (return-from get-variable-description variable-description))) 154 | 155 | (defun make-template-widget (template &rest args) 156 | (make-instance 'user-template-widget 157 | :template template 158 | :variables args)) 159 | 160 | (defun make-template-widget-from-model-object (template model-object &rest args) 161 | (apply #'make-template-widget (append (list template) args (object-values-and-descriptions model-object)))) 162 | 163 | (defun object-values-and-descriptions (object) 164 | "Returns plist suitable for passing as variables params to `make-template-widget`" 165 | (let ((description (weblocks-cms::get-model-description 166 | (alexandria:make-keyword (class-name (class-of object)))))) 167 | 168 | (flet ((get-field-description (field) 169 | (loop for i in (getf description :fields) 170 | if (equal (getf i :name) field) 171 | do (return-from get-field-description i)))) 172 | 173 | (loop for i in (c2mop:class-slots (class-of object)) 174 | append (let ((field-descr (get-field-description (alexandria:make-keyword (c2mop:slot-definition-name i))))) 175 | (list 176 | (alexandria:make-keyword (c2mop:slot-definition-name i)) 177 | (cons (slot-value object (c2mop:slot-definition-name i)) 178 | (or (getf field-descr :title) "")))))))) 179 | 180 | (defun get-widget-by-template-name (template-name) 181 | (loop for i in (get-widgets-by-type 'user-template-widget) 182 | do 183 | (when (equal (slot-value i 'template) template-name) 184 | (return-from get-widget-by-template-name i)))) 185 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | Preamble to the Gnu Lesser General Public License 2 | 3 | Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 4 | 5 | The concept of the GNU Lesser General Public License version 2.1 6 | ("LGPL") has been adopted to govern the use and distribution of 7 | above-mentioned application. However, the LGPL uses terminology that 8 | is more appropriate for a program written in C than one written in 9 | Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if 10 | certain clarifications are made. This document details those 11 | clarifications. Accordingly, the license for the open-source Lisp 12 | applications consists of this document plus the LGPL. Wherever there 13 | is a conflict between this document and the LGPL, this document takes 14 | precedence over the LGPL. 15 | 16 | A "Library" in Lisp is a collection of Lisp functions, data and 17 | foreign modules. The form of the Library can be Lisp source code (for 18 | processing by an interpreter) or object code (usually the result of 19 | compilation of source code or built with some other 20 | mechanisms). Foreign modules are object code in a form that can be 21 | linked into a Lisp executable. When we speak of functions we do so in 22 | the most general way to include, in addition, methods and unnamed 23 | functions. Lisp "data" is also a general term that includes the data 24 | structures resulting from defining Lisp classes. A Lisp application 25 | may include the same set of Lisp objects as does a Library, but this 26 | does not mean that the application is necessarily a "work based on the 27 | Library" it contains. 28 | 29 | The Library consists of everything in the distribution file set before 30 | any modifications are made to the files. If any of the functions or 31 | classes in the Library are redefined in other files, then those 32 | redefinitions ARE considered a work based on the Library. If 33 | additional methods are added to generic functions in the Library, 34 | those additional methods are NOT considered a work based on the 35 | Library. If Library classes are subclassed, these subclasses are NOT 36 | considered a work based on the Library. If the Library is modified to 37 | explicitly call other functions that are neither part of Lisp itself 38 | nor an available add-on module to Lisp, then the functions called by 39 | the modified Library ARE considered a work based on the Library. The 40 | goal is to ensure that the Library will compile and run without 41 | getting undefined function errors. 42 | 43 | It is permitted to add proprietary source code to the Library, but it 44 | must be done in a way such that the Library will still run without 45 | that proprietary code present. Section 5 of the LGPL distinguishes 46 | between the case of a library being dynamically linked at runtime and 47 | one being statically linked at build time. Section 5 of the LGPL 48 | states that the former results in an executable that is a "work that 49 | uses the Library." Section 5 of the LGPL states that the latter 50 | results in one that is a "derivative of the Library", which is 51 | therefore covered by the LGPL. Since Lisp only offers one choice, 52 | which is to link the Library into an executable at build time, we 53 | declare that, for the purpose applying the LGPL to the Library, an 54 | executable that results from linking a "work that uses the Library" 55 | with the Library is considered a "work that uses the Library" and is 56 | therefore NOT covered by the LGPL. 57 | 58 | Because of this declaration, section 6 of LGPL is not applicable to 59 | the Library. However, in connection with each distribution of this 60 | executable, you must also deliver, in accordance with the terms and 61 | conditions of the LGPL, the source code of Library (or your derivative 62 | thereof) that is incorporated into this executable. 63 | 64 | GNU LESSER GENERAL PUBLIC LICENSE 65 | Version 3, 29 June 2007 66 | 67 | Copyright (C) 2007 Free Software Foundation, Inc. 68 | Everyone is permitted to copy and distribute verbatim copies 69 | of this license document, but changing it is not allowed. 70 | 71 | 72 | This version of the GNU Lesser General Public License incorporates 73 | the terms and conditions of version 3 of the GNU General Public 74 | License, supplemented by the additional permissions listed below. 75 | 76 | 0. Additional Definitions. 77 | 78 | As used herein, "this License" refers to version 3 of the GNU Lesser 79 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 80 | General Public License. 81 | 82 | "The Library" refers to a covered work governed by this License, 83 | other than an Application or a Combined Work as defined below. 84 | 85 | An "Application" is any work that makes use of an interface provided 86 | by the Library, but which is not otherwise based on the Library. 87 | Defining a subclass of a class defined by the Library is deemed a mode 88 | of using an interface provided by the Library. 89 | 90 | A "Combined Work" is a work produced by combining or linking an 91 | Application with the Library. The particular version of the Library 92 | with which the Combined Work was made is also called the "Linked 93 | Version". 94 | 95 | The "Minimal Corresponding Source" for a Combined Work means the 96 | Corresponding Source for the Combined Work, excluding any source code 97 | for portions of the Combined Work that, considered in isolation, are 98 | based on the Application, and not on the Linked Version. 99 | 100 | The "Corresponding Application Code" for a Combined Work means the 101 | object code and/or source code for the Application, including any data 102 | and utility programs needed for reproducing the Combined Work from the 103 | Application, but excluding the System Libraries of the Combined Work. 104 | 105 | 1. Exception to Section 3 of the GNU GPL. 106 | 107 | You may convey a covered work under sections 3 and 4 of this License 108 | without being bound by section 3 of the GNU GPL. 109 | 110 | 2. Conveying Modified Versions. 111 | 112 | If you modify a copy of the Library, and, in your modifications, a 113 | facility refers to a function or data to be supplied by an Application 114 | that uses the facility (other than as an argument passed when the 115 | facility is invoked), then you may convey a copy of the modified 116 | version: 117 | 118 | a) under this License, provided that you make a good faith effort to 119 | ensure that, in the event an Application does not supply the 120 | function or data, the facility still operates, and performs 121 | whatever part of its purpose remains meaningful, or 122 | 123 | b) under the GNU GPL, with none of the additional permissions of 124 | this License applicable to that copy. 125 | 126 | 3. Object Code Incorporating Material from Library Header Files. 127 | 128 | The object code form of an Application may incorporate material from 129 | a header file that is part of the Library. You may convey such object 130 | code under terms of your choice, provided that, if the incorporated 131 | material is not limited to numerical parameters, data structure 132 | layouts and accessors, or small macros, inline functions and templates 133 | (ten or fewer lines in length), you do both of the following: 134 | 135 | a) Give prominent notice with each copy of the object code that the 136 | Library is used in it and that the Library and its use are 137 | covered by this License. 138 | 139 | b) Accompany the object code with a copy of the GNU GPL and this license 140 | document. 141 | 142 | 4. Combined Works. 143 | 144 | You may convey a Combined Work under terms of your choice that, 145 | taken together, effectively do not restrict modification of the 146 | portions of the Library contained in the Combined Work and reverse 147 | engineering for debugging such modifications, if you also do each of 148 | the following: 149 | 150 | a) Give prominent notice with each copy of the Combined Work that 151 | the Library is used in it and that the Library and its use are 152 | covered by this License. 153 | 154 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 155 | document. 156 | 157 | c) For a Combined Work that displays copyright notices during 158 | execution, include the copyright notice for the Library among 159 | these notices, as well as a reference directing the user to the 160 | copies of the GNU GPL and this license document. 161 | 162 | d) Do one of the following: 163 | 164 | 0) Convey the Minimal Corresponding Source under the terms of this 165 | License, and the Corresponding Application Code in a form 166 | suitable for, and under terms that permit, the user to 167 | recombine or relink the Application with a modified version of 168 | the Linked Version to produce a modified Combined Work, in the 169 | manner specified by section 6 of the GNU GPL for conveying 170 | Corresponding Source. 171 | 172 | 1) Use a suitable shared library mechanism for linking with the 173 | Library. A suitable mechanism is one that (a) uses at run time 174 | a copy of the Library already present on the user's computer 175 | system, and (b) will operate properly with a modified version 176 | of the Library that is interface-compatible with the Linked 177 | Version. 178 | 179 | e) Provide Installation Information, but only if you would otherwise 180 | be required to provide such information under section 6 of the 181 | GNU GPL, and only to the extent that such information is 182 | necessary to install and execute a modified version of the 183 | Combined Work produced by recombining or relinking the 184 | Application with a modified version of the Linked Version. (If 185 | you use option 4d0, the Installation Information must accompany 186 | the Minimal Corresponding Source and Corresponding Application 187 | Code. If you use option 4d1, you must provide the Installation 188 | Information in the manner specified by section 6 of the GNU GPL 189 | for conveying Corresponding Source.) 190 | 191 | 5. Combined Libraries. 192 | 193 | You may place library facilities that are a work based on the 194 | Library side by side in a single library together with other library 195 | facilities that are not Applications and are not covered by this 196 | License, and convey such a combined library under terms of your 197 | choice, if you do both of the following: 198 | 199 | a) Accompany the combined library with a copy of the same work based 200 | on the Library, uncombined with any other library facilities, 201 | conveyed under the terms of this License. 202 | 203 | b) Give prominent notice with the combined library that part of it 204 | is a work based on the Library, and explaining where to find the 205 | accompanying uncombined form of the same work. 206 | 207 | 6. Revised Versions of the GNU Lesser General Public License. 208 | 209 | The Free Software Foundation may publish revised and/or new versions 210 | of the GNU Lesser General Public License from time to time. Such new 211 | versions will be similar in spirit to the present version, but may 212 | differ in detail to address new problems or concerns. 213 | 214 | Each version is given a distinguishing version number. If the 215 | Library as you received it specifies that a certain numbered version 216 | of the GNU Lesser General Public License "or any later version" 217 | applies to it, you have the option of following the terms and 218 | conditions either of that published version or of any later version 219 | published by the Free Software Foundation. If the Library as you 220 | received it does not specify a version number of the GNU Lesser 221 | General Public License, you may choose any version of the GNU Lesser 222 | General Public License ever published by the Free Software Foundation. 223 | 224 | If the Library as you received it specifies that a proxy can decide 225 | whether future versions of the GNU Lesser General Public License shall 226 | apply, that proxy's public statement of acceptance of any version is 227 | permanent authorization for you to choose that version for the 228 | Library. 229 | -------------------------------------------------------------------------------- /weblocks-cms-pages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; weblocks-cms-pages.lisp 2 | 3 | (in-package #:weblocks-cms-pages) 4 | 5 | ;;; "weblocks-cms-pages" goes here. Hacks and glory await! 6 | 7 | (defvar *pages-ru-translation-table* 8 | '(("no name" . "без имени") 9 | ("String" . "Строка") 10 | ("Widget" . "Виджет") 11 | ("empty" . "пусто") 12 | ("Function" . "Функция") 13 | ("Template output" . "Вывод шаблона") 14 | ; 15 | ("Site Page" . "Страница сайта") 16 | ("Page Content" . "Содержимое") 17 | ("Site Path" . "Путь на сайте") 18 | ("Parent Page" . "Родительская страница") 19 | ("Page Title" . "Название") 20 | ("Page Name" . "Внутреннее название"))) 21 | 22 | (defmethod weblocks-cms:tree-item-title ((obj weblocks-cms::page)) 23 | "Displaying page information string on site page gridedit" 24 | (format nil " ~A (~A)" 25 | (if (weblocks-cms::page-name obj) 26 | (format nil "~A" (weblocks-cms::page-name obj)) 27 | (format nil "~A" (translate "no name"))) 28 | (with-slots (weblocks-cms::content) obj 29 | (cond 30 | ((typep weblocks-cms::content 'weblocks-cms::template) 31 | (template-tree-path-pretty-print weblocks-cms::content)) 32 | ((stringp weblocks-cms::content) 33 | (format nil "~A - \"~A\"" (translate "String") weblocks-cms::content)) 34 | ((and 35 | (consp weblocks-cms::content) 36 | (equal (car weblocks-cms::content) 37 | :widget)) 38 | (format nil "~A - ~A" (translate "Widget") (get-widget-title-by-name (cdr weblocks-cms::content)))) 39 | ((and 40 | (consp weblocks-cms::content) 41 | (equal (car weblocks-cms::content) 42 | :callback)) 43 | (format nil "~A - ~A" (translate "Function") (get-callback-title-by-name (cdr weblocks-cms::content)))) 44 | (t "empty"))))) 45 | 46 | (defmethod template-tree-path-pretty-print ((obj weblocks-cms::template)) 47 | "How template looks in content field of site page gridedit form" 48 | (format nil "~A - ~A" (translate "Template output") (weblocks-cms::template-name obj))) 49 | 50 | (defmethod template-tree-path-pretty-print ((obj string)) 51 | "How string looks in content field of site page gridedit form" 52 | obj) 53 | 54 | (defmethod template-tree-path-pretty-print ((obj cons)) 55 | "How widget looks in content field of site page gridedit form" 56 | (case (car obj) 57 | (:widget (format nil "~A - ~A" (translate "Widget") (get-widget-title-by-name (cdr obj)))) 58 | (:callback (format nil "~A - ~A" (translate "Function") (get-callback-title-by-name (cdr obj)))) 59 | (t (error "Not implemented work with cons ~A" obj)))) 60 | 61 | (defmethod weblocks-cms::get-view-fields-for-field-type-and-description :around (type description model-description-list) 62 | "Content field for site page gridedit form" 63 | (if (and 64 | (equal (getf model-description-list :name) :page) 65 | (equal (getf description :name) :content)) 66 | (progn 67 | (setf (getf description :options) "template") 68 | (let ((relation-model-description-list (weblocks-cms::get-model-description-from-field-description-options description))) 69 | (list 70 | (list 71 | (weblocks-cms::keyword->symbol (getf description :name)) 72 | :label (getf description :title) 73 | :present-as (list 74 | 'bootstrap-typeahead 75 | :display-create-message nil 76 | :choices 77 | (lambda (item) 78 | (append 79 | (get-pages-widgets-titles) 80 | (get-pages-callbacks-titles) 81 | (loop for i in (all-of (weblocks-cms::keyword->symbol (getf relation-model-description-list :name))) 82 | collect (template-tree-path-pretty-print i))))) 83 | :reader (lambda (item) 84 | (let ((item (slot-value item (weblocks-cms::keyword->symbol (getf description :name))))) 85 | (and 86 | item 87 | (template-tree-path-pretty-print item)))) 88 | :writer (lambda (value item) 89 | (let ((object (cond 90 | ((ppcre:scan (translate "Template output") value) 91 | (ppcre:register-groups-bind 92 | (name) 93 | ((format nil "~A~A" 94 | (translate "Template output") 95 | "\\s+-\\s+(.*)$") value) 96 | (first-by-values 'weblocks-cms::template :name name))) 97 | ((ppcre:scan (translate "Widget") value) 98 | (ppcre:register-groups-bind 99 | (title) 100 | ((format nil "~A~A" 101 | (translate "Widget") 102 | "\\s+-\\s+(.*)$") value) 103 | (cons :widget (get-widget-name-by-title title)))) 104 | ((ppcre:scan (translate "Function") value) 105 | (ppcre:register-groups-bind 106 | (title) 107 | ((format nil "~A~A" (translate "Function") "\\s+-\\s+(.*)$") value) 108 | (cons :callback (get-callback-name-by-title title)))) 109 | (t value)))) 110 | (setf (slot-value item (weblocks-cms::keyword->symbol (getf description :name))) object))))))) 111 | (call-next-method))) 112 | 113 | (defwidget pages-container (composite) 114 | ((selected :initform nil :accessor pages-container-selected)) 115 | (:documentation "Widget that contains navigation stuff for pages functionality") 116 | (:default-initargs :uri-id :pages)) 117 | 118 | (defun maybe-replace-with-other-lang-template (template) 119 | (let ((other-lang-template 120 | (first-by-values 121 | 'weblocks-cms::template 122 | :name 123 | (format nil "~A-~A" 124 | (weblocks-cms::template-name template) 125 | (string-downcase (weblocks::current-locale)))))) 126 | (or other-lang-template template))) 127 | 128 | (defun page-content (page) 129 | (if (typep (weblocks-cms::page-content page) 'weblocks-cms::template) 130 | (maybe-replace-with-other-lang-template (weblocks-cms::page-content page)) 131 | (weblocks-cms::page-content page))) 132 | 133 | (defun get-page-content (page) 134 | (weblocks::timing (format nil "content-item--~A" (slot-value page 'weblocks-cms::name)) 135 | (get-page-content-string 136 | (weblocks-cms::page-content page) 137 | (weblocks-utils:find-by-values 'weblocks-cms::page :parent page)))) 138 | 139 | (defun make-routes-for-pages () 140 | "Connects routes to pages-container widget" 141 | (clear-static-variables-routes-for-variable *routes-mapper* :pages.selected) 142 | (loop for i in (weblocks-utils:find-by-values 'weblocks-cms::page :parent nil) do 143 | (connect *routes-mapper* 144 | (make-routes-with-static-value 145 | :pages.selected 146 | `((,(weblocks-cms::page-path i) . ,(weblocks-cms::page-path i))))))) 147 | 148 | (defmacro with-yaclml (&body body) 149 | "A wrapper around cl-yaclml with-yaclml-stream macro." 150 | `(yaclml:with-yaclml-stream *weblocks-output-stream* 151 | ,@body)) 152 | 153 | (defmethod render-widget ((obj pages-container) &rest args) 154 | (make-routes-for-pages) 155 | 156 | (with-yaclml 157 | (<:div :id (dom-id obj) 158 | (with-slots (selected) obj 159 | (when (and (not selected) 160 | (not (first-by-values 'weblocks-cms::page :path "/"))) 161 | (return-from render-widget 162 | (mapcar #'render-widget (widget-children obj)))) 163 | 164 | (let ((page (first-by-values 'weblocks-cms::page :path (or selected "/") :parent nil)) 165 | (page-content)) 166 | (setf *current-page-title* (weblocks-cms::page-title page)) 167 | (setf page-content (get-page-content page)) 168 | (setf (slot-value obj 'weblocks::children) (list page-content)) 169 | (render-widget page-content)) 170 | (pushnew 171 | (lambda () 172 | (setf selected nil)) 173 | (request-hook :request :post-render)))))) 174 | 175 | (defmethod widget-children ((obj pages-container) &optional type) 176 | (let ((ret (or (slot-value obj 'weblocks::children) 177 | #+l(setf (slot-value obj 'weblocks::children) 178 | (list (get-page-content (first-by-values 'weblocks-cms::page :path (or (slot-value obj 'selected) "/") :parent nil))))))) 179 | (loop for i in ret 180 | collect (if (listp i) 181 | (second i) 182 | i)))) 183 | 184 | (defmethod get-page-content-string :around (obj children) 185 | (weblocks::timing 186 | (if (subtypep (type-of obj) 'weblocks-cms::template) 187 | (format nil "get content string from template ~A" (weblocks-cms::template-name obj)) 188 | (format nil "get content string from ~A" (prin1-to-string obj))) 189 | (call-next-method))) 190 | 191 | (defmethod get-page-content-string ((obj weblocks-cms::template) children) 192 | (let ((template (alexandria:make-keyword (string-upcase (weblocks-cms::template-name obj))))) 193 | (apply #'make-template-widget 194 | (list* 195 | template 196 | (loop for i in children 197 | append (let ((var (alexandria:make-keyword (string-upcase (weblocks-cms::page-name i))))) 198 | (list 199 | var 200 | (cons 201 | (get-page-content i) 202 | (get-variable-description template var))))))))) 203 | 204 | (defmethod get-page-content-string ((obj null) children) 205 | (format nil "~{~A~}" 206 | (loop for i in children 207 | collect (get-page-content i)))) 208 | 209 | (defmethod get-page-content-string ((obj string) children) 210 | (format nil "~{~A~}" 211 | (list* obj 212 | (loop for i in children 213 | collect (get-page-content i))))) 214 | 215 | (defmethod get-page-content-string ((obj list) children) 216 | (if (equal (car obj) :widget) 217 | (make-page-widget-from-name (cdr obj) children) 218 | (call-next-method))) 219 | 220 | (defvar *pages-widgets* nil 221 | "Contains list of widget information. Each widget information piece contains widget name, widget title and widget callback") 222 | 223 | (defun add-page-widget (name title callback) 224 | "Creates page widget, 225 | name is the internal name used as widget id, 226 | title is the title displayed in pages tree, 227 | callback is the callback which should return widget" 228 | (push (list name title callback) *pages-widgets*) 229 | (setf *pages-widgets* (reverse (remove-duplicates (reverse *pages-widgets*) :key #'car)))) 230 | 231 | (defun get-pages-widgets-titles () 232 | "Lists widget titles for displaying in dropdown list" 233 | (loop for (name title callback) in *pages-widgets* 234 | collect (template-tree-path-pretty-print (cons :widget name)))) 235 | 236 | (defun get-widget-name-by-title (given-title) 237 | "Finds widget by title, returns its name" 238 | (loop for (name title callback) in *pages-widgets* 239 | if (string= title given-title) 240 | do (return-from get-widget-name-by-title name))) 241 | 242 | (defun get-widget-title-by-name (given-name) 243 | "Finds widget by name, returns its title" 244 | (loop for (name title callback) in *pages-widgets* 245 | if (string= name given-name) 246 | do (return-from get-widget-title-by-name title))) 247 | 248 | (defun make-page-widget-from-name (given-name children) 249 | "Finds widget by name, creates new instance of widget using children" 250 | (loop for (name title callback) in *pages-widgets* 251 | if (equal name given-name) 252 | do (return-from make-page-widget-from-name (funcall callback given-name children)))) 253 | 254 | (defun render-page-by-name (name) 255 | "Finds page by name and renders it" 256 | (render-widget (get-page-content (first-by-values 'weblocks-cms::page :name (string-downcase name))))) 257 | 258 | (defvar *pages-callbacks* nil 259 | "Contains list of widget information. Each widget information piece contains widget name, widget title and widget callback") 260 | 261 | (defun add-page-callback (name title callback) 262 | "Creates page callback, 263 | name is the internal name used as callback id, 264 | title is the title displayed in pages tree, 265 | callback is the callback itself which should return something" 266 | (push (list name title callback) *pages-callbacks*) 267 | (setf *pages-callbacks* (reverse (remove-duplicates (reverse *pages-callbacks*) :key #'car)))) 268 | 269 | (defun get-pages-callbacks-titles () 270 | "Lists widget titles for displaying in dropdown list" 271 | (loop for (name title callback) in *pages-callbacks* 272 | collect (template-tree-path-pretty-print (cons :callback name)))) 273 | 274 | (defun get-callback-name-by-title (given-title) 275 | "Finds widget by title, returns its name" 276 | (loop for (name title callback) in *pages-callbacks* 277 | if (string= title given-title) 278 | do (return-from get-callback-name-by-title name))) 279 | 280 | (defun get-callback-title-by-name (given-name) 281 | "Finds widget by name, returns its title" 282 | (loop for (name title callback) in *pages-callbacks* 283 | if (string= name given-name) 284 | do (return-from get-callback-title-by-name title))) 285 | 286 | (defun funcall-page-callback (given-name children) 287 | "Finds widget by name, creates new instance of widget using children" 288 | (loop for (name title callback) in *pages-callbacks* 289 | if (equal name given-name) 290 | do (return-from funcall-page-callback (funcall callback given-name children)))) 291 | --------------------------------------------------------------------------------