;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI                                 ;;;;
;;;; (c) David Botton                                                      ;;;;
;;;;                                                                       ;;;;
;;;; clog-web-dbi.lisp                                                     ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Database components for use with clog-web websites

(mgl-pax:define-package :clog-web-dbi
  (:documentation "CLOG-WEB-DBI - dbi based website helpers")
  (:use #:cl #:clog #:clog-web #:clog-auth #:mgl-pax))

(cl:in-package :clog-web-dbi)

(defsection @clog-web-dbi (:title "CLOG Web DBI")
  "Authentication"
  (login              function)
  (logout             function)
  (get-profile        function)
  (sign-up            function)
  (change-password    function)
  (reset-password     function)
  (make-token         function)
  (load-content       function)
  (create-base-tables function))

;;;;;;;;;;;;;;;;;
;; get-profile ;;
;;;;;;;;;;;;;;;;;

(defun get-profile (obj sql-connection)
  "Retrieve profile based on current authentication token. If there is
no token or fails to match as user returns nil"
  (let* ((body  (connection-body obj))
         (token (clog-auth:get-authentication-token body)))
    (when token
      (let ((contents (dbi:fetch-all
                       (dbi:execute
                        (dbi:prepare
                         sql-connection
                         "select * from users where token=?")
                        (list token)))))
        (when contents
          (car contents))))))

;;;;;;;;;;;
;; login ;;
;;;;;;;;;;;

(defun login (body sql-connection username password)
  "Login and set current authentication token, it does not remove token
if one is present and login fails."
  (check-type body clog-body)
  (let ((contents (dbi:fetch-all
                   (dbi:execute
                    (dbi:prepare
                     sql-connection
                     "select * from users where username=?")
                    (list username)))))
    (when (and contents
               (cl-pass:check-password password (getf (car contents) :|password|)))
      (store-authentication-token body (getf (car contents) :|token|)))))

;;;;;;;;;;;;
;; logout ;;
;;;;;;;;;;;;

(defun logout (body)
  "Logout and remove current authenitcation token"
  (check-type body clog-body)
  (remove-authentication-token body))

;;;;;;;;;;;;;
;; sign-up ;;
;;;;;;;;;;;;;

(defun sign-up (body sql-connection &key (title "Sign Up")
                                      (next-step "/login"))
  "Setup a sign-up form and process a new sign-up"
  (check-type body clog-body)
  (clog-web-form
   body title
   `(("Username" "username")
     ("Password" "password" :password)
     ("Retype Password" "repass" :password))
   (lambda (result)
     (cond ((not
             (equal (form-result result "password")
                    (form-result result "repass")))
            (clog-web-alert body "Mismatch"
                            "The passwords do match."
                            :time-out 3
                            :place-top t))
           ((< (length (form-result result "password")) 4)
            (clog-web-alert body "Missize"
                            "The passwords must at least 4 characters."
                            :time-out 3
                            :place-top t))
           ((< (length (form-result result "username")) 4)
            (clog-web-alert body "Missize"
                            "The username must be at least 4 characters."
                            :time-out 3
                            :place-top t))
           (t
            (let ((contents (dbi:fetch-all
                             (dbi:execute
                              (dbi:prepare
                               sql-connection
                               "select username from users where username=?")
                              (list (form-result result "username"))))))
              (cond (contents
                     (clog-web-alert body "Exists"
                                     "The username is not available."
                                     :time-out 3
                                     :place-top t))
                    (t
                     (dbi:do-sql
                       sql-connection
                       (sql-insert*
                        "users"
                        `(:username ,(form-result result "username")
                          :password ,(cl-pass:hash (form-result result "password"))
                          :token    ,(make-token))))
                     (url-replace (location body) next-step)))))))))

;;;;;;;;;;;;;;;;;;;;;
;; change-password ;;
;;;;;;;;;;;;;;;;;;;;;

(defun change-password (body sql-connection &key (title "Change Password")
                                              (next-step "/"))
  "Setup a change password form and handle change of password"
  (check-type body clog-body)
  (clog-web-form
   body title
   `(("Old Password" "oldpass" :password)
     ("New Password" "password" :password)
     ("Retype Password" "repass" :password))
   (lambda (result)
     (cond ((not
             (equal (form-result result "password")
                    (form-result result "repass")))
            (clog-web-alert body "Password Mismatch"
                            "The new passwords do match."
                            :time-out 3
                            :place-top t))
           ((< (length (form-result result "password")) 4)
            (clog-web-alert body "Password Missize"
                            "The new passwords must at least 4 characters."
                            :time-out 3
                            :place-top t))
           (t
            (let ((contents (dbi:fetch-all
                             (dbi:execute
                              (dbi:prepare
                               sql-connection
                               "select username, password from users where username=?")
                              (list (getf (profile (get-web-site body)) :|username|))))))
              (cond ((and contents
                          (cl-pass:check-password (form-result result "oldpass")
                                                  (getf (car contents) :|password|)))
                     (dbi:do-sql
                       sql-connection
                       (sql-update
                        "users"
                        `(:password ,(cl-pass:hash (form-result result "password")))
                        "username=?")
                       (list (getf (profile (get-web-site body)) :|username|)))
                     (url-replace (location body) next-step))
                    (t
                     (clog-web-alert body "Old Password"
                                     "Old password is incorrect."
                                     :time-out 3
                                     :place-top t)))))))))

;;;;;;;;;;;;;;;;;;;;
;; reset-password ;;
;;;;;;;;;;;;;;;;;;;;

(defun reset-password (sql-connection username &key (new-password "password"))
  "Reset USERNAME's password to :NEW-PASSWORD"
  (print username)

  (dbi:do-sql
    sql-connection
    (sql-update
     "users"
     `(:password ,(cl-pass:hash new-password))
     "username=?")
    (list username)))

;;;;;;;;;;;;;;;;
;; make-token ;;
;;;;;;;;;;;;;;;;

(defun make-token ()
  "Create a unique token used to associate a browser with a user"
  (crypto:byte-array-to-hex-string
   (crypto:random-data 16)))

;;;;;;;;;;;;;;;;;;;;;;;
;; create-base-table ;;
;;;;;;;;;;;;;;;;;;;;;;;

(defun create-base-tables (sql-connection &key (sql-timestamp-func *sqlite-timestamp*))
  "Create default tables"
  (dbi:do-sql
    sql-connection
    "create table config (key varchar, value varchar)")
  (dbi:do-sql
    sql-connection
    (format nil "create table content (key varchar, value varchar,~
                                       parent varchar, title varchar,~
                                       username varchar, createdate date)"))
  (dbi:do-sql
    sql-connection
    "create table tags (key varchar, value varchar, category varchar)")
  (dbi:do-sql
    sql-connection
    "create table users (username varchar, password varchar, token varchar)")
  (dbi:do-sql
    sql-connection
    (sql-insert* "content" `(:key        "main"
                             :title      "Welcome to CLOG"
                             :value      "Sample data"
                             :createdate (,sql-timestamp-func))))
  (dbi:do-sql
    sql-connection
    (sql-insert* "users" `(:username "admin"
                           :password ,(cl-pass:hash "admin")
                           :token    ,(make-token)))))

;;;;;;;;;;;;;;;;;;
;; load-content ;;
;;;;;;;;;;;;;;;;;;

(defun load-content (sql-connection table key-value &key
                                                      (key-col "key")
                                                      where
                                                      order-by)
  "Returns list of records found in TABLE where KEY-COL = KEY-VALUE and
optional WHERE and ORDER-BY sql."
  (let ((contents (dbi:fetch-all
                   (dbi:execute
                    (dbi:prepare
                     sql-connection
                     (format nil "select * from ~A where ~A=? ~A ~A"
                             table key-col
                             (if where
                                 (format nil "and ~A" where)
                                 "")
                             (if order-by
                                 (format nil "order by ~A" order-by)
                                 "")))
                    (list key-value)))))
    contents))

;;;;;;;;;;;;;;;;;;;;;;
;; clog-web-content ;;
;;;;;;;;;;;;;;;;;;;;;;

(defun clog-web-content (sql-connection
                         &key
                           (page               "main")
                           (table              "content")
                           (base-url           "/content")
                           (follow-url-page    t)
                           comment-table
                           on-content
                           on-comment
                           on-new
                           on-edit
                           on-delete
                           (can-admin          :content-admin)
                           (can-comment        :content-comment)
                           (can-show-comments  :content-show-comments)
                           (can-edit           :content-edit)
                           (content-order-by   "createdate")
                           (comment-order-by   "createdate desc")
                           (sql-timestamp-func *sqlite-timestamp*))
  "This is used to create PAGE based content. If more than one entry in
TABLE is keyed for same PAGE, if theme is configured for it, displays
a table of contents, followed by each content record, followed by
comments for the whole page.

Creates content for CLOG-WEB:CREATE-WEB-PAGE based on TABLE where
key=PAGE (or if FOLLOW-URL-PAGE is true PAGE is default page and if no
second on path otherwise page is the second on path, first must be
base-url). e.g.

(defun on-main (body)
  (init-site body)
  (create-web-page body
    :index `(:menu    ,*menu*
             :content ,(clog-web-content *sql-connection*
             :comment-table \"content\"))))

ON-CONTENT, ON-COMMENT are called with (obj value) before
display of value the return value is used. ON-NEW, ON-EDIT are called
with (obj value) to allow filter of value before storage, if nil is
return aborted. ON-DELETE called with (obj page comment-id) if returns
nil aborted. If comment-table is nil no comments are shown. User must
authorize on action set by CAN-COMMENT, CAN-ADMIN, CAN-SHOW-COMMENTS
and if CAN-EDIT unless they are set to nil."
  (lambda (obj)
    (let* ((body    (connection-body obj))
           (theme   (theme (get-web-site body)))
           (prof    (profile (get-web-site body)))
           (roles   (roles (get-web-site body)))
           (url     (base-url-split base-url (path-name (location body)))))
      ;; set page to show content
      (when follow-url-page
        (when (second url)
          (setf page (second url))))
      ;; page content display
      (let ((pages (load-content sql-connection table page
                                 :order-by content-order-by)))
        ;; ask theme for table of contents or to allow add
        (funcall theme obj :content-contents
                 (list :content pages
                       :do-add (when (clog-auth:is-authorized-p roles can-edit)
                                 (lambda (content)
                                   (push (list sql-timestamp-func) content)
                                   (push :createdate content)
                                   (push page content)
                                   (push :key content)
                                   (push page content)
                                   (push :username content)
                                   (when on-new
                                     (setf content (funcall on-new content)))
                                   (when content
                                     (dbi:do-sql
                                       sql-connection
                                       (sql-insert* table content)))))))
        (dolist (content pages)
          (when content
            (when on-content
              (setf content (funcall on-content obj content)))
            (funcall theme obj :content-body
                     (list :content content
                           :save-edit (when (clog-auth:is-authorized-p roles can-edit)
                                        (lambda (new-content)
                                          (when on-edit
                                            (setf new-content (funcall on-edit new-content)))
                                          (when new-content
                                            (dbi:do-sql
                                              sql-connection
                                              (sql-update table
                                                          new-content
                                                          "key=? and createdate=?")
                                              (list page (getf content :|createdate|)))
                                            (print (getf content :|createdate|)))))
                           :do-delete (when (clog-auth:is-authorized-p roles can-edit)
                                        (lambda ()
                                          (if on-delete
                                              (setf on-delete (setf on-delete (funcall on-delete obj page nil)))
                                              (setf on-delete t))
                                          (when on-delete
                                            (dbi:do-sql
                                              sql-connection
                                              (format nil "delete from ~A where key=? and createdate=?" table)
                                              (list page (getf content :|createdate|))))))
                           :new-comment (when (clog-auth:is-authorized-p
                                               roles can-comment)
                                          (lambda (content)
                                            (push (list sql-timestamp-func) content)
                                            (push :|createdate| content)
                                            (push (list sql-timestamp-func) content)
                                            (push :|key| content)
                                            (push page content)
                                            (push :|parent| content)
                                            (push (getf prof :|username|) content)
                                            (push :|username| content)
                                            (when on-new
                                              (setf content (funcall on-new content)))
                                            (when content
                                              (dbi:do-sql
                                                sql-connection
                                                (sql-insert* comment-table content))))))))))
      ;; comments display
      (when (and (clog-auth:is-authorized-p roles can-show-comments)
                 comment-table)
        (let ((comments (load-content sql-connection comment-table page
                                      :key-col  "parent"
                                      :order-by comment-order-by)))
          (dolist (comment comments)
            (when on-comment
              (setf comment (funcall on-comment obj comment)))
            (funcall theme obj :content-comment
                     (list :content comment
                           :do-delete (when (or (clog-auth:is-authorized-p roles can-admin)
                                                (and (getf prof :|username|)
                                                     (equalp (getf comment :|username|)
                                                             (getf prof    :|username|))))
                                        (lambda ()
                                          (if on-delete
                                              (setf on-delete (funcall on-delete obj page (getf comment :|key|)))
                                              (setf on-delete t))
                                          (when on-delete
                                            (if (clog-auth:is-authorized-p roles can-admin)
                                                (dbi:do-sql
                                                  sql-connection
                                                  (format nil "delete from ~A where key=? and parent=?"
                                                          comment-table)
                                                  (list (getf comment :|key|) page))
                                                (dbi:do-sql
                                                  sql-connection
                                                  (format nil "delete from ~A where key=? and username=? and parent=?"
                                                          comment-table)
                                                  (list (getf comment :|key|) (getf prof :|username|) page))))))
                           :save-edit (when (or (clog-auth:is-authorized-p roles can-admin)
                                                (and (getf prof :|username|)
                                                     (equalp (getf comment :|username|)
                                                             (getf prof    :|username|))))
                                        (lambda (content)
                                          (when on-edit
                                            (setf content (funcall on-edit content)))
                                          (when content
                                            (dbi:do-sql
                                              sql-connection
                                              (sql-update comment-table
                                                          content
                                                          "key=?")
                                              (list (getf comment :|key|))))))))))))))
