clog/tutorial/31-tutorial.lisp

;; Demonstrates clog-web-site using a database oriented setup
;; using clog-web-dbi for users and clog-auth for authentication
;; and authorization

(defpackage #:clog-tut-31
  (:use #:cl #:clog #:clog-web #:clog-auth #:clog-web-dbi)
  (:export start-tutorial))

(in-package #:clog-tut-31)

;;
;; Setup website structure, database and CLOG
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *sql-connection* nil)

;; Default user/pass is username: admin and password: admin

;; We use authorizations to control what menus appear if logged in or not.
;; We use the :authorize key on create-web-page to limit access as well
;; directly to a page when not using menus.
;; We use our menu with the convenient clog-web-routes-from-menu to
;; setup the routes from URLs to handlers:

                      ; Menu         Menu Item   URL       Handler   Actions Auth
(defparameter *menu* `(("Features" (("Login"     "/login"  on-login  :login)
                                    ("Signup"    "/signup" on-signup :signup)
                                    ("Main"      "/main"   on-main   :main)
                                    ("Logout"    "/logout" on-logout :logout)))
                       ("Admin"    (("User List" "/users"  on-users  :users)))
                       ("Help"     (("About"     "/about"  on-about))))
  "Setup website menu")

(defun start-tutorial ()
  ;; Setup authorizations between roles and actions
  (add-authorization '(:guest) '(:login :signup :main))
  (add-authorization '(:member) '(:logout :main))
  (add-authorization '(:admin) '(:users))
  ;; Setup database connection
  (when *sql-connection*
    (dbi:disconnect *sql-connection*))
  (let ((db-dir (format nil "~A~A" (asdf:system-source-directory :clog) "tut-31.db")))
    (setf *sql-connection* (dbi:connect :sqlite3 :database-name db-dir))
    (format t "Database location: ~A~%" db-dir))
  ;; Check if need to setup sample data
  (handler-case
      (dbi:fetch (dbi:execute (dbi:prepare *sql-connection* "select * from config")))
    (error ()
      (print "Create database and tables.")
      (create-base-tables *sql-connection*)))
  ;; Setup clog, using long polling for web crawlers and some meta info
  (initialize 'on-main
              :long-poll-first t
              :boot-function (clog-web-meta
                              "clogpower.com - CLOG - the common lisp omnificent gui"))
  (clog-web-routes-from-menu *menu*)
  (open-browser))

;;
;; Look and Feel
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun init-site (body)
  "Setup the website, called on each url switch"
  ;; Initialize the clog-web environment
  (clog-web-initialize body)
  ;; Instantly reload other windows open on authentication change
  (set-on-authentication-change body (lambda (body)
                                       (url-replace (location body) "/")))
  ;; Initialzie the clog-web-site environment
  (let ((profile (get-profile body *sql-connection*)))
    (create-web-site body
                     :settings '(:color-class  "w3-blue-gray"
                                 :border-class ""
                                 :signup-link  "/signup"
                                 :login-link   "/login")
                     :profile profile
                     :roles (if profile
                                (if (equalp "admin"
                                            (getf profile :|username|))
                                    '(:member :admin)
                                    '(:member))
                                '(:guest))
                     :title "CLOG - The Common Lisp Omnificent GUI"
                     :footer "(c) 2022 David Botton"
                     :logo "/img/clog-liz.png")))

;;
;; URL Path Handlers
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun on-login (body)
  (init-site body)
  (create-web-page
   body
   :login `(:menu      ,*menu*
            :on-submit ,(lambda (obj)
                          (if (login body *sql-connection*
                                     (name-value obj "username")
                                     (name-value obj "password"))
                              ;; url-replace removes login from history stack
                              (url-replace (location body) "/main")
                              (clog-web-alert obj "Invalid" "The username and password are invalid."
                                              :time-out 3
                                              :place-top t))))
   ;; don't authorize use of page if logged in
   :authorize t))

(defun on-logout (body)
  (logout body)
  (url-replace (location body) "/"))

(defun on-signup (body)
  (init-site body)
  (create-web-page body
                   :signup `(:menu    ,*menu*
                             :content ,(lambda (body)
                                         (sign-up body *sql-connection*)))
                   ;; don't authorize use of page if logged in
                   :authorize t))

(defun on-main (body)
  (init-site body)
  (create-web-page body :main `(:menu    ,*menu*
                                :content "I am the main page")))

(defun on-about (body)
  (init-site body)
  (create-web-page body :about `(:menu    ,*menu*
                                 :content "About Me")))

(defun on-users (body)
  (init-site body)
  (create-web-page body :users
                   `(:menu    ,*menu*
                     :content ,(lambda (body)
                                 (let ((users (dbi:fetch-all
                                               (dbi:execute
                                                (dbi:prepare
                                                 *sql-connection*
                                                 "select * from users")))))
                                   (dolist (user users)
                                     (create-div body :content (getf user :|username|))))))
                   ;; don't authorize use of page unless you are the admin
                        :authorize t))