mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 10:40:45 -08:00
1191 lines
47 KiB
Common Lisp
1191 lines
47 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
|
|
;;;; (c) 2020-2022 David Botton ;;;;
|
|
;;;; License BSD 3 Clause ;;;;
|
|
;;;; ;;;;
|
|
;;;; clog-web.lisp ;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Like clog-gui, clog-web uses w3.css as the underlying framework. w3.css is
|
|
;;; a public domain css only framework for layouts, is fast and efficient and
|
|
;;; does not require additional components outside of the css file. The goal
|
|
;;; of clog-web is to help make it easier to create "webpage" style apps
|
|
;;; (page layout instead of a more direct layout around the browser window
|
|
;;; as in clog-gui that mimics a desktop environment) or actual webpages
|
|
;;; (traditional hyper-linking, submition of forms and minimal need for an
|
|
;;; active clog connection).
|
|
|
|
(mgl-pax:define-package :clog-web
|
|
(:documentation "CLOG-WEB a web page style abstraction for CLOG")
|
|
(:use #:cl #:parse-float #:clog #:mgl-pax))
|
|
|
|
(cl:in-package :clog-web)
|
|
|
|
(defsection @clog-web (:title "CLOG Web Objects")
|
|
"CLOG-WEB - Web page abstraction for CLOG"
|
|
(clog-web-initialize function)
|
|
(set-maximum-page-width-in-pixels function)
|
|
|
|
"CLOG-WEB - General Containers"
|
|
(clog-web-panel class)
|
|
(create-web-panel generic-function)
|
|
(clog-web-content class)
|
|
(create-web-content generic-function)
|
|
(clog-web-code class)
|
|
(create-web-code generic-function)
|
|
(clog-web-main class)
|
|
(create-web-main generic-function)
|
|
(clog-web-sidebar class)
|
|
(create-web-sidebar generic-function)
|
|
(clog-web-sidebar-item class)
|
|
(create-web-sidebar-item generic-function)
|
|
(clog-web-sidebar-item class)
|
|
(create-web-sidebar-item generic-function)
|
|
(clog-web-compositor class)
|
|
(create-web-compositor generic-function)
|
|
(web-padding-class-type type)
|
|
(composite-on-hover generic-function)
|
|
(composite-position generic-function)
|
|
(composite-top-middle generic-function)
|
|
(composite-top-left generic-function)
|
|
(composite-top-right generic-function)
|
|
(composite-bottom-middle generic-function)
|
|
(composite-bottom-left generic-function)
|
|
(composite-bottom-right generic-function)
|
|
(composite-middle generic-function)
|
|
(composite-left generic-function)
|
|
(composite-right generic-function)
|
|
|
|
"CLOG-WEB - Auto Layout System"
|
|
(clog-web-auto-row class)
|
|
(create-web-auto-row generic-function)
|
|
(clog-web-auto-column class)
|
|
(create-web-auto-column generic-function)
|
|
|
|
"CLOG-WEB - 12 Column Grid Layout System"
|
|
(clog-web-row class)
|
|
(create-web-row generic-function)
|
|
(clog-web-container class)
|
|
(create-web-container generic-function)
|
|
|
|
"CLOG-WEB - Look and Feel"
|
|
(add-card-look generic-function)
|
|
(add-hard-card-look generic-function)
|
|
|
|
"CLOG-WEB - Mobile"
|
|
(full-row-on-mobile generic-function)
|
|
(hide-on-small-screens generic-function)
|
|
(hide-on-medium-screens generic-function)
|
|
(hide-on-large-screens generic-function)
|
|
|
|
"CLOG-WEB - Menus"
|
|
(clog-web-menu-bar class)
|
|
(create-web-menu-bar generic-function)
|
|
(web-menu-bar generic-function)
|
|
(web-menu-bar-height generic-function)
|
|
(clog-web-menu-drop-down class)
|
|
(create-web-menu-drop-down generic-function)
|
|
(clog-web-menu-item class)
|
|
(create-web-menu-item generic-function)
|
|
(create-web-menu-full-screen generic-function)
|
|
(create-web-menu-icon generic-function)
|
|
|
|
"CLOG-WEB - Interactions"
|
|
(clog-web-alert function)
|
|
(clog-web-form function)
|
|
(form-result function)
|
|
|
|
"CLOG-WEB - Websites"
|
|
(clog-web-site class)
|
|
(create-web-site generic-function)
|
|
(get-web-site generic-function)
|
|
(create-web-page generic-function)
|
|
|
|
"CLOG-WEB-SITE - Accessors"
|
|
(theme generic-function)
|
|
(settings generic-function)
|
|
(profile generic-function)
|
|
(roles generic-function)
|
|
(url generic-function)
|
|
(title generic-function)
|
|
(footer generic-function)
|
|
(logo generic-function)
|
|
|
|
"CLOG-WEB - Utilities"
|
|
(clog-web-routes-from-menu function)
|
|
(clog-web-meta function)
|
|
(base-url-p function)
|
|
(adjust-for-base-url function)
|
|
(base-url-split function))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - clog-web - CLOG Web page abstraction
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web ()
|
|
((body
|
|
:accessor body
|
|
:documentation "Top level access to browser window")
|
|
(web-site
|
|
:accessor web-site
|
|
:initform nil
|
|
:documentation "The clog-web-site if installed")
|
|
(web-menu
|
|
:accessor web-menu
|
|
:initform nil
|
|
:documentation "Installed menu bar if installed")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-clog-web ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun create-clog-web (clog-body)
|
|
"Create a clog-web object and places it in CLOG-BODY's connection-data as
|
|
\"clog-web\". (Private)"
|
|
(let ((clog-web (make-instance 'clog-web)))
|
|
(setf (connection-data-item clog-body "clog-web") clog-web)
|
|
(setf (body clog-web) clog-body)
|
|
clog-web))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; clog-web-initialize ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun clog-web-initialize (clog-body &key (w3-css-url "/css/w3.css"))
|
|
"Initializes clog-web and installs a clog-web object on connection.
|
|
If W3-CSS-URL has not been loaded before is installed unless is nil."
|
|
(create-clog-web clog-body)
|
|
(unless (connection-data-item clog-body "w3-css")
|
|
(when w3-css-url
|
|
(setf (connection-data-item clog-body "w3-css") t)
|
|
(load-css (html-document clog-body) w3-css-url))))
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; web-menu-bar ;;
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric web-menu-bar (clog-obj)
|
|
(:documentation "Get/setf window web-menu-bar. This is set buy
|
|
create-web-menu-bar."))
|
|
|
|
(defmethod web-menu-bar ((obj clog-obj))
|
|
(let ((app (connection-data-item obj "clog-web")))
|
|
(web-menu app)))
|
|
|
|
(defgeneric (setf web-menu-bar) (value clog-obj)
|
|
(:documentation "Set window web-menu-bar"))
|
|
|
|
(defmethod (setf web-menu-bar) (value (obj clog-obj))
|
|
(let ((app (connection-data-item obj "clog-web")))
|
|
(setf (web-menu app) value)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; web-menu-bar-height ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric web-menu-bar-height (clog-obj)
|
|
(:documentation "Get web-menu-bar height"))
|
|
|
|
(defmethod web-menu-bar-height ((obj clog-obj))
|
|
(let ((app (connection-data-item obj "clog-web")))
|
|
(if (web-menu app)
|
|
(height (web-menu app))
|
|
0)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-menu-bar ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-menu-bar (clog-div)()
|
|
(:documentation "Menu bar"))
|
|
|
|
(defgeneric create-web-menu-bar (clog-obj &key class html-id)
|
|
(:documentation "Attach a menu bar to a CLOG-OBJ generally a
|
|
clog-body."))
|
|
|
|
(defmethod create-web-menu-bar ((obj clog-obj)
|
|
&key (class nil)
|
|
(html-id nil))
|
|
(let* ((div (create-div obj :class class :html-id html-id))
|
|
(tmp (create-span div)) ; corrects css issue with w3.css
|
|
(app (connection-data-item obj "clog-web")))
|
|
(declare (ignore tmp))
|
|
(add-class div "w3-bar")
|
|
(change-class div 'clog-web-menu-bar)
|
|
(setf (web-menu app) div)
|
|
div))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-menu-drop-down ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-menu-drop-down (clog-div)()
|
|
(:documentation "Drop down menu"))
|
|
|
|
(defgeneric create-web-menu-drop-down (clog-web-menu-bar
|
|
&key content class html-id)
|
|
(:documentation "Attached a menu bar drop-down to a CLOG-WEB-MENU-BAR"))
|
|
|
|
(defmethod create-web-menu-drop-down ((obj clog-web-menu-bar)
|
|
&key (content "")
|
|
(class nil)
|
|
(html-id nil))
|
|
(let* ((hover (create-div obj :class "w3-dropdown-hover"))
|
|
(button (create-button hover :class "w3-button" :content content))
|
|
(div (create-div hover :class class :html-id html-id)))
|
|
(declare (ignore button))
|
|
(add-class div "w3-dropdown-content")
|
|
(add-class div "w3-bar-block")
|
|
(change-class div 'clog-web-menu-drop-down)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-menu-item ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-menu-item (clog-span)()
|
|
(:documentation "Menu item"))
|
|
|
|
(defgeneric create-web-menu-item (clog-web-menu-drop-down
|
|
&key content
|
|
link
|
|
on-click
|
|
class
|
|
html-id)
|
|
(:documentation "Attached a menu item to a CLOG-WEB-MENU-DROP-DOWN.
|
|
Use to set a link or on-click to set an on-click handler"))
|
|
|
|
(defmethod create-web-menu-item ((obj clog-obj)
|
|
&key (content "")
|
|
(link nil)
|
|
(on-click nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((span
|
|
(create-span (if link
|
|
(create-a obj :class class :link link)
|
|
obj)
|
|
:content content
|
|
:class (unless link class)
|
|
:html-id html-id)))
|
|
(add-class span "w3-bar-item")
|
|
(add-class span "w3-button")
|
|
(set-on-click span on-click)
|
|
(change-class span 'clog-web-menu-item)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-menu-full-screen ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric create-web-menu-full-screen (clog-web-menu-bar &key html-id)
|
|
(:documentation "Add as last item in menu bar to allow for a full screen
|
|
icon ⤢ and full screen mode."))
|
|
|
|
(defmethod create-web-menu-full-screen ((obj clog-web-menu-bar)
|
|
&key (html-id nil))
|
|
(create-child obj
|
|
" <span class='w3-bar-item w3-right' style='user-select:none;'
|
|
onClick='if (document.fullscreenElement==null) {
|
|
documentElement.requestFullscreen()
|
|
} else {document.exitFullscreen();}'>⤢</span>"
|
|
:html-id html-id
|
|
:clog-type 'clog-web-menu-item))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-menu-icon ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric create-web-menu-icon (clog-web-menu-bar &key image-url
|
|
on-click
|
|
class
|
|
html-id)
|
|
(:documentation "Add icon as menu bar item."))
|
|
|
|
(defmethod create-web-menu-icon ((obj clog-web-menu-bar)
|
|
&key (image-url "/img/clogicon.png")
|
|
(on-click nil)
|
|
(class "w3-button w3-bar-item")
|
|
(html-id nil))
|
|
(set-on-click
|
|
(create-child obj
|
|
(format nil "<button class='~A'>~
|
|
<img height=22 src='~A'></button>"
|
|
class
|
|
image-url)
|
|
:html-id html-id
|
|
:clog-type 'clog-web-menu-item)
|
|
on-click))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; set-maximum-page-width-in-pixels ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun set-maximum-page-width-in-pixels (clog-body width)
|
|
"The default width is 980 pixels."
|
|
(add-class clog-body "w3-content")
|
|
(setf (maximum-width clog-body) (unit "px" width)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;
|
|
;; add-card-look ;;
|
|
;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric add-card-look (clog-element)
|
|
(:documentation "Change clog-element to use 2px card look"))
|
|
|
|
(defmethod add-card-look ((obj clog-element))
|
|
(add-class obj "w3-card-2"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; add-hard-card-look ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric add-hard-card-look (clog-element)
|
|
(:documentation "Change clog-element to use 4px card look"))
|
|
|
|
(defmethod add-hard-card-look ((obj clog-element))
|
|
(add-class obj "w3-card-4"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; full-row-on-mobile ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric full-row-on-mobile (clog-element)
|
|
(:documentation "Change element to display:block, take up the full row, when
|
|
screen size smaller then 601 pixels DP"))
|
|
|
|
(defmethod full-row-on-mobile ((obj clog-element))
|
|
(add-class obj "w3-mobile"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; hide-on-small-screens ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric hide-on-small-screens (clog-element)
|
|
(:documentation "Hide element on screens smaller then 601 pixels DP"))
|
|
|
|
(defmethod hide-on-small-screens ((obj clog-element))
|
|
(add-class obj "w3-hide-small"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; hide-on-medium-screens ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric hide-on-medium-screens (clog-element)
|
|
(:documentation "Hide element on screens smaller then 993 pixels DP"))
|
|
|
|
(defmethod hide-on-medium-screens ((obj clog-element))
|
|
(add-class obj "w3-hide-medium"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; hide-on-large-screens ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric hide-on-large-screens (clog-element)
|
|
(:documentation "Hide element on screens smaller then 993 pixels DP"))
|
|
|
|
(defmethod hide-on-large-screens ((obj clog-element))
|
|
(add-class obj "w3-hide-large"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - General Containers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Container - Sample Uses
|
|
;; ----------------- --------------------------------------------
|
|
;; Content - Fixed size centered Content
|
|
;; Panel - Notes, Quote boxes, Notifications
|
|
;; Display-Container - Image text overlays
|
|
;; Code - Code blocks
|
|
;; Sidebar - Sidebar to main content, optional collapsable
|
|
;; Main - Mark main contact when using a sidebar
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-panel ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-panel (clog-div)()
|
|
(:documentation "Panel for web content"))
|
|
|
|
(defgeneric create-web-panel (clog-obj &key content hidden class html-id)
|
|
(:documentation "Create a clog-web-panel. General container with 16px left
|
|
and right padding and 16x top and bottom margin. If hidden is t then then the
|
|
visiblep propetery will be set to nil on creation."))
|
|
|
|
(defmethod create-web-panel ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-panel")
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-panel)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-content ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-content (clog-div)()
|
|
(:documentation "Content for web content"))
|
|
|
|
(defgeneric create-web-content (clog-obj &key content maximum-width
|
|
hidden class html-id)
|
|
(:documentation "Create a clog-web-content. General container with 16px left
|
|
and right padding. If hidden is t then then the visiblep propetery will be set
|
|
to nil on creation."))
|
|
|
|
(defmethod create-web-content ((obj clog-obj) &key (content "")
|
|
(maximum-width nil)
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-content")
|
|
(when maximum-width
|
|
(setf (maximum-width div) (unit "px" maximum-width)))
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-content)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-compositor ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-compositor (clog-div)()
|
|
(:documentation "Compositor for compositing layers of web content"))
|
|
|
|
(defgeneric create-web-compositor (clog-obj &key content hidden class html-id)
|
|
(:documentation "Create a clog-web-compositor. Allows compositing of content
|
|
on top of other content. Content is added as children and then
|
|
composit-location is called on the object of that content. If hidden is t then
|
|
then the visiblep propetery will be set to nil on creation."))
|
|
|
|
(defmethod create-web-compositor ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-display-container")
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-compositor)))
|
|
|
|
;;;;;;;;;;;;;;;;;
|
|
;; composite-* ;;
|
|
;;;;;;;;;;;;;;;;;
|
|
|
|
(deftype web-padding-class-type ()
|
|
'(member :padding-small :padding :padding-large :padding-16 :padding-24
|
|
:padding-32 :padding-48 :padding-64 :padding-top-64 :padding-top-48
|
|
:padding-top-48 :padding-top-32))
|
|
|
|
(defgeneric composite-on-hover (clog-element)
|
|
(:documentation "Composite CLOG-ELEMENT on on-hover."))
|
|
|
|
(defmethod composite-on-hover ((obj clog-element))
|
|
(add-class obj "w3-display-hover"))
|
|
|
|
(defgeneric composite-position (clog-element &key top left padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT to coordinate top left."))
|
|
|
|
(defmethod composite-position ((obj clog-element)
|
|
&key
|
|
(top 0) (left 0)
|
|
(padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-position~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
"")))
|
|
(setf (top obj) (unit :px top))
|
|
(setf (left obj) (unit :px left)))
|
|
|
|
(defgeneric composite-top-middle (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on top-middle."))
|
|
|
|
(defmethod composite-top-middle ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-topmiddle~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-bottom-middle (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on bottom-middle."))
|
|
|
|
(defmethod composite-bottom-middle ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-bottommiddle~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-bottom-right (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on bottom-right."))
|
|
|
|
(defmethod composite-bottom-right ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-bottomright~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-bottom-left (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on bottom-left."))
|
|
|
|
(defmethod composite-bottom-left ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-bottomleft~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-top-right (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on top-right."))
|
|
|
|
(defmethod composite-top-right ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-topright~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-top-left (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on top-left."))
|
|
|
|
(defmethod composite-top-left ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-topleft~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-left (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on left."))
|
|
|
|
(defmethod composite-left ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-left~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-middle (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on middle."))
|
|
|
|
(defmethod composite-middle ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-middle~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
(defgeneric composite-right (clog-element &key padding-class)
|
|
(:documentation "Composite CLOG-ELEMENT on right."))
|
|
|
|
(defmethod composite-right ((obj clog-element)
|
|
&key (padding-class nil))
|
|
(add-class obj
|
|
(format nil "w3-display-right~A"
|
|
(if padding-class
|
|
(format nil " w3-~A" (string-downcase padding-class))
|
|
""))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-code ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-code (clog-div)()
|
|
(:documentation "Code for web code"))
|
|
|
|
(defgeneric create-web-code (clog-obj &key content
|
|
hidden class html-id)
|
|
(:documentation "Create a clog-web-code. Code content container.
|
|
If hidden is t then then the visiblep propetery will be set
|
|
to nil on creation."))
|
|
|
|
(defmethod create-web-code ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-code")
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-code)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-main ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-main (clog-div)()
|
|
(:documentation "Main for web content"))
|
|
|
|
(defgeneric create-web-main (clog-obj &key content hidden class html-id)
|
|
(:documentation "Create a clog-web-main. Container for main content
|
|
when using a collapsable sidebar or other whole page shifting
|
|
technique. If hidden is t then then the visiblep propetery will be set
|
|
to nil on creation."))
|
|
|
|
(defmethod create-web-main ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-main")
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-main)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-sidebar ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-sidebar (clog-div)()
|
|
(:documentation "Sidebar for web content"))
|
|
|
|
(defgeneric create-web-sidebar (clog-obj &key content hidden class html-id)
|
|
(:documentation "Create a clog-web-sidebar. Container for sidebar content.
|
|
sidebars are create with the display property set to :none if hidden it t
|
|
and :block if nil. In general the visiblep property is used in clog, however
|
|
in clog-web-sidebar the block property is needed to activate its animations
|
|
if used. If using a sidebar that will take space and not collapse, make sure
|
|
to set the sidebar's size and set a margin equal to the size on the main
|
|
container."))
|
|
|
|
(defmethod create-web-sidebar ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(setf (display div) :none)
|
|
(setf (visiblep div) t)
|
|
(add-class div "w3-sidebar w3-bar-block")
|
|
(unless hidden
|
|
(setf (display div) :block))
|
|
(change-class div 'clog-web-sidebar)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-sidebar-item ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-sidebar-item (clog-button)()
|
|
(:documentation "Sidebar-Item for web content"))
|
|
|
|
(defgeneric create-web-sidebar-item (clog-obj &key content hidden class html-id)
|
|
(:documentation "Create a clog-web-sidebar-item. A sidebar menu bar item.
|
|
If hidden is t then then the visiblep propetery will be set to nil on
|
|
creation."))
|
|
|
|
(defmethod create-web-sidebar-item ((obj clog-obj) &key (content "")
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((item (create-button obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class item "w3-bar-item w3-button")
|
|
(unless hidden
|
|
(setf (visiblep item) t))
|
|
(change-class item 'clog-web-sidebar-item)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - Auto Layout
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Container - Sample Uses
|
|
;; ----------------- ----------------------------------------------------
|
|
;; Auto-Row - Container of Auto-Columns
|
|
;; Auto-Column - Columns size adjusts width to fix contents of all
|
|
;; columns to fill 100% and all heights equal
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-auto-row ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-auto-row (clog-div)()
|
|
(:documentation "Content for web content"))
|
|
|
|
(defgeneric create-web-auto-row (clog-obj &key hidden class html-id)
|
|
(:documentation "Create a clog-web-auto-row. Container for auto-columns
|
|
If hidden is t then then the visiblep propetery will be set to nil on
|
|
creation."))
|
|
|
|
(defmethod create-web-auto-row ((obj clog-obj) &key (hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-cell-row")
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-auto-row)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-auto-column ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(deftype web-vertical-align-type () '(member :top :middle :bottom))
|
|
|
|
(defclass clog-web-auto-column (clog-div)()
|
|
(:documentation "Content for web content"))
|
|
|
|
(defgeneric create-web-auto-column (clog-obj &key content vertical-align
|
|
hidden class html-id)
|
|
(:documentation "Create a clog-web-auto-column. Container for auto-columns
|
|
If hidden is t then then the visiblep propetery will be set to nil on
|
|
creation."))
|
|
|
|
(defmethod create-web-auto-column ((obj clog-obj) &key (content "")
|
|
(vertical-align nil)
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-cell")
|
|
(when vertical-align
|
|
(add-class div (format nil "w3-cell-~A"
|
|
(string-downcase vertical-align))))
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-auto-column)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - Responsive 12 part grid
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Container - Sample Uses
|
|
;; ----------------- ----------------------------------------------------
|
|
;; Row - Container of grid columns (Containers)
|
|
;; Container - Headers, Footers, General, 12 part Grid Columns
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-row ;;
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-row (clog-div)()
|
|
(:documentation "Row to contain columns of web content in 12 column grid"))
|
|
|
|
(defgeneric create-web-row (clog-obj &key padding hidden class html-id)
|
|
(:documentation "Create a clog-web-row. If padding is true 8px left and
|
|
right padding is addded. If hidden is t then then the visiblep propetery will
|
|
be set to nil on creation."))
|
|
|
|
(defmethod create-web-row ((obj clog-obj) &key (padding nil)
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :hidden t :class class :html-id html-id)))
|
|
(if padding
|
|
(add-class div "w3-row-padding")
|
|
(add-class div "w3-row"))
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-row)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-container ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(deftype web-container-size-type () '(member :half :third :twothird :quarter
|
|
:threequarter :rest :col))
|
|
|
|
(defclass clog-web-container (clog-div)()
|
|
(:documentation "Container cells for web content in 12 column grid"))
|
|
|
|
(defgeneric create-web-container (clog-obj &key content
|
|
column-size
|
|
hidden class html-id)
|
|
(:documentation "Create a clog-web-container. COLUMN-SIZE can be of type
|
|
container-size-type when to set size displayed on medium and large screens
|
|
or can use a string of \"s1-12 m1-12 l1-12\" s m or l followed by how many
|
|
columns this container uses on small, medium or large screens. Small screens
|
|
are always displayed full row. Total columns must add to 12 or one needs to
|
|
be of type :w3-rest to fill space. If hidden is t then then the visiblep
|
|
propetery will be set to nil on creation."))
|
|
|
|
(defmethod create-web-container ((obj clog-obj) &key (content "")
|
|
(column-size nil)
|
|
(hidden nil)
|
|
(class nil)
|
|
(html-id nil))
|
|
(let ((div (create-div obj :content content
|
|
:hidden t :class class :html-id html-id)))
|
|
(add-class div "w3-container")
|
|
(when column-size
|
|
(add-class div (format nil "w3-~A" (string-downcase column-size))))
|
|
(unless hidden
|
|
(setf (visiblep div) t))
|
|
(change-class div 'clog-web-container)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - clog-web Interactions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun clog-web-alert (obj title content &key
|
|
(color-class "w3-red")
|
|
(time-out nil)
|
|
(place-top nil)
|
|
(html-id nil))
|
|
"Create an alert toast with option :TIME-OUT. If place-top is t then alert
|
|
is placed in DOM at top of OBJ instead of bottom of OBJ."
|
|
(unless html-id
|
|
(setf html-id (clog-connection:generate-id)))
|
|
(let* ((panel (create-child obj
|
|
(format nil
|
|
" <div class='w3-panel ~A w3-animate-right w3-display-container'>~
|
|
<span id='~A-closer' class='w3-button w3-large w3-display-topright'>×</span>~
|
|
<h3>~A</h3>~
|
|
<p>~A</p>~
|
|
</div>"
|
|
color-class
|
|
html-id
|
|
title
|
|
content)
|
|
:html-id html-id
|
|
:auto-place nil)))
|
|
(if place-top
|
|
(place-inside-top-of obj panel)
|
|
(place-inside-bottom-of obj panel))
|
|
(set-on-click
|
|
(attach-as-child obj (format nil "~A-closer" html-id))
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(destroy panel)))
|
|
(when time-out
|
|
(sleep time-out)
|
|
(destroy panel))))
|
|
|
|
(defun form-result (result key)
|
|
"Return the value for KEY from RESULT"
|
|
(second (assoc key result :test #'equal)))
|
|
|
|
(defun clog-web-form (obj content fields on-input &key (modal nil)
|
|
(ok-text "OK")
|
|
(cancel-text "Cancel")
|
|
(border-class "w3-border")
|
|
(text-class "w3-text-black")
|
|
(color-class "w3-black")
|
|
(html-id nil))
|
|
"Create a form with CONTENT followed by FIELDS.
|
|
FIELDS is a list of lists each list has:
|
|
|
|
(1) Field description - Used for label
|
|
(2) Field name - Used for (name attribute)
|
|
(3) Field type - Optional (defaults to :text)
|
|
(4) Field type options - Optional
|
|
|
|
Special field types
|
|
|
|
Field Type Field Type Options
|
|
============= ==================
|
|
:checkbox t if checked
|
|
:radiobox a-list ((label name)) a third value can be added \"checked\"
|
|
:select a-list ((label name)) a third value can be added \"selected\"
|
|
:text value
|
|
(any text input types also work :email, :tel, etc.
|
|
see FORM-ELEMENT-TYPE)
|
|
|
|
Calls on-input after OK or Cancel with an a-list of field name to value
|
|
if confirmed or nil if canceled. CANCEL-TEXT is only displayed if modal is t
|
|
|
|
If clog-web-site is being used the class class setting will be replaced with
|
|
the value if set in the theme settings."
|
|
(let* ((app (connection-data-item obj "clog-web"))
|
|
(website (web-site app)))
|
|
(when website
|
|
(when (getf (settings website) :text-class)
|
|
(setf text-class (getf (settings website) :text-class)))
|
|
(when (getf (settings website) :border-class)
|
|
(setf border-class (getf (settings website) :border-class)))
|
|
(when (getf (settings website) :color-class)
|
|
(setf color-class (getf (settings website) :color-class)))))
|
|
(unless html-id
|
|
(setf html-id (clog-connection:generate-id)))
|
|
(let* ((fls (format nil "~{~A~}"
|
|
(mapcar (lambda (l)
|
|
(cond
|
|
((eq (third l) :select)
|
|
(format nil
|
|
"<p><label class='~A'>~A</label>~
|
|
<select class='w3-select ~A' name='~A-~A'>~A</select></p>"
|
|
text-class (first l)
|
|
border-class html-id (second l)
|
|
(format nil "~{~A~}"
|
|
(mapcar (lambda (s)
|
|
(format nil
|
|
"<option value='~A' ~A>~A</option>"
|
|
(second s)
|
|
(if (third s)
|
|
(third s)
|
|
"")
|
|
(first s)))
|
|
(fourth l)))))
|
|
((eq (third l) :radio)
|
|
(format nil
|
|
"<p><label class='~A'>~A</label>~A</p>"
|
|
text-class (first l)
|
|
(format nil "~{~A~}"
|
|
(mapcar (lambda (s)
|
|
(format nil
|
|
"<p><input type=radio class='w3-radio' name='~A-~A'~
|
|
id='~A-~A-~A' value='~A' ~A> ~
|
|
<label for='~A-~A-~A'>~A</label></p>"
|
|
html-id (second l)
|
|
html-id (second l) (second s)
|
|
(second s)
|
|
(if (third s)
|
|
(third s)
|
|
"")
|
|
html-id (second l) (second s)
|
|
(first s)))
|
|
(fourth l)))))
|
|
((eq (third l) :checkbox)
|
|
(format nil
|
|
"<p><input class='w3-check' type='checkbox' ~
|
|
name='~A-~A' id='~A-~A' ~A> ~
|
|
<label class='~A' for='~A-~A'>~
|
|
~A</label>~
|
|
</p>"
|
|
html-id (second l) html-id (second l)
|
|
(if (fourth l)
|
|
"checked"
|
|
"")
|
|
text-class html-id (second l)
|
|
(first l)))
|
|
((third l)
|
|
(format nil
|
|
"<p><label class='~A'>~A</label>~
|
|
<input class='w3-input ~A' type='~A'~
|
|
name='~A-~A' id='~A-~A' value='~A'></p>"
|
|
text-class (first l)
|
|
border-class (third l)
|
|
html-id (second l) html-id (second l)
|
|
(if (fourth l)
|
|
(fourth l)
|
|
"")))
|
|
(t
|
|
(format nil
|
|
"<p><label class='~A'>~A</label>~
|
|
<input class='w3-input ~A' type='text' name='~A-~A' id='~A-~A'></p>"
|
|
text-class (first l)
|
|
border-class html-id (second l) html-id (second l)))))
|
|
fields)))
|
|
(win (create-web-content obj
|
|
:content (format nil
|
|
"<div class='w3-panel'>
|
|
~A
|
|
<form class='w3-container' onSubmit='return false;'>
|
|
~A
|
|
<br><center>
|
|
<button class='w3-button ~A' style='width:7em' id='~A-ok'>~A</button>~A
|
|
</center>
|
|
</form>
|
|
</div>" (if content
|
|
(format nil "<center>~A</center><br>" content)
|
|
"")
|
|
fls
|
|
color-class html-id ok-text ; ok
|
|
(if modal
|
|
(format nil " <button class='w3-button ~A' style='width:7em' id='~A-cancel'>~A</button>"
|
|
color-class html-id cancel-text)
|
|
""))
|
|
:hidden t
|
|
:html-id html-id))
|
|
(ok (attach-as-child win (format nil "~A-ok" html-id)))
|
|
(cancel (if modal
|
|
(attach-as-child win (format nil "~A-cancel" html-id))
|
|
nil)))
|
|
(declare (ignore cancel))
|
|
(setf (visiblep win) t)
|
|
(when modal
|
|
(js-execute obj (format nil "$('[name=~A-~A]').focus()"
|
|
html-id
|
|
(cadar fields))))
|
|
(set-on-click ok (lambda (obj)
|
|
(declare (ignore obj))
|
|
(let ((result (mapcar
|
|
(lambda (l)
|
|
`(,(second l)
|
|
,(let ((name (format nil "~A-~A" html-id (second l))))
|
|
(cond ((eq (third l) :select)
|
|
(select-value win name))
|
|
((eq (third l) :radio)
|
|
(radio-value win name))
|
|
((eq (third l) :checkbox)
|
|
(checkbox-value win name))
|
|
(t
|
|
(name-value win name))))))
|
|
fields)))
|
|
(funcall on-input result)))
|
|
:one-time nil)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Implementation - clog-web Websites
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-site ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass clog-web-site ()
|
|
((theme :initarg :theme
|
|
:accessor theme)
|
|
(profile :initarg :profile
|
|
:accessor profile)
|
|
(roles :initarg :roles
|
|
:accessor roles)
|
|
(settings :initarg :settings
|
|
:reader settings)
|
|
(url :initarg :url
|
|
:reader url)
|
|
(title :initarg :title
|
|
:reader title)
|
|
(footer :initarg :footer
|
|
:reader footer)
|
|
(logo :initarg :logo
|
|
:reader logo))
|
|
(:documentation "Website information"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-site ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric create-web-site (clog-obj &key
|
|
settings
|
|
profile
|
|
roles
|
|
theme
|
|
url
|
|
title
|
|
footer
|
|
logo)
|
|
(:documentation "Attach a clog-web-site to a CLOG-OBJ generally a
|
|
clog-body."))
|
|
|
|
(defmethod create-web-site ((obj clog-obj) &key
|
|
settings
|
|
(profile nil)
|
|
(roles nil)
|
|
(theme 'default-theme)
|
|
(url "/")
|
|
(title "")
|
|
(footer "")
|
|
(logo ""))
|
|
(let ((website (make-instance 'clog-web-site
|
|
:settings settings
|
|
:profile profile
|
|
:roles roles
|
|
:theme theme
|
|
:url url
|
|
:title title
|
|
:footer footer
|
|
:logo logo))
|
|
(app (connection-data-item obj "clog-web")))
|
|
(setf (web-site app) website)
|
|
website))
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; get-web-site ;;
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric get-web-site (clog-obj)
|
|
(:documentation "Retrieve the clog-web-site object created on CLOG-OBJ's
|
|
connection"))
|
|
|
|
(defmethod get-web-site ((obj clog-obj))
|
|
(let* ((app (connection-data-item obj "clog-web"))
|
|
(website (web-site app)))
|
|
website))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
;; create-web-page ;;
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defgeneric create-web-page (clog-obj page properties &key authorize)
|
|
(:documentation "Use the clog-web-site THEME to create PAGE with
|
|
CLOG-OBJ as parent. PAGE is a symbol to identify the pages purpose to
|
|
the website theme. Themes are required to provide certain default
|
|
pages see clog-web-themes file. If AUTHORIZE then PAGE is used also as
|
|
a CLOG-Auth action to be checked if the current users roles have
|
|
permission to PAGE"))
|
|
|
|
(defmethod create-web-page ((obj clog-obj) page properties &key authorize)
|
|
(if (or (and authorize
|
|
(clog-auth:is-authorized-p (roles (get-web-site obj)) page))
|
|
(not authorize))
|
|
(funcall (theme (get-web-site obj))
|
|
obj page properties)
|
|
(create-div obj :content "Authorization failure")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Utilities
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;
|
|
;; clog-web-meta ;;
|
|
;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun clog-web-meta (description)
|
|
"Returns a boot-function for use with CLOG:INITIALIZE to add meta
|
|
and no-script body information for search engines with DESCRIPTION."
|
|
(lambda (path content)
|
|
(declare (ignore path))
|
|
(funcall (cl-template:compile-template content)
|
|
(list :meta (format nil "<meta name='description' content='~A'>"
|
|
description)
|
|
:body description))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; clog-web-routes-from-menu ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun clog-web-routes-from-menu (menu)
|
|
"Use a menu to setup a route for each menu item that has a third
|
|
element."
|
|
(dolist (drop-down menu)
|
|
(dolist (item (second drop-down))
|
|
(when (third item)
|
|
(set-on-new-window (third item) :path (second item))))))
|
|
|
|
;;;;;;;;;;;;;;;;
|
|
;; base-url-p ;;
|
|
;;;;;;;;;;;;;;;;
|
|
|
|
(defun base-url-p (base-url url-path)
|
|
"True if url-path is based on base-url"
|
|
(ppcre:scan (format nil "^~A/" base-url) (format nil "~A/" url-path)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; adjust-for-base-url ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun adjust-for-base-url (base-url url-path)
|
|
"If url-path is not on base-url return base-url otherwise url-path"
|
|
(if (base-url-p base-url url-path)
|
|
url-path
|
|
base-url))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;; base-url-split ;;
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun base-url-split (base-url url-path)
|
|
"Split path by / adjusting for base-url"
|
|
(let ((s (ppcre:split "/" (adjust-for-base-url base-url url-path))))
|
|
(if (equal (car s) "")
|
|
(cdr s)
|
|
s)))
|