cl-deck-builder2/src/web/user.lisp

#|

src/web/user.lisp

User Interaction Frontend

|#

(in-package :cl-deck-builder2.web)

;; This seems to be okay. The intent of overriding HERMETIC::AUTHORIZE
;; is we use MITO-AUTH for user authentication and their class isn't
;; just a password hash. So this is an undocumented way of customizing
;; authorization method using HERMETIC.
(defun hermetic::authorize (username password)
  (let ((object (funcall hermetic::*user-p* username)))
    (and object
         (string= (mito-auth:password-hash object)
                  (mito-auth::make-password-hash
                   password
                   (mito-auth:password-salt object))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun already-logged-in-redirect ()
  "Tell the user they are already logged in, and send them to the home page."
  (progn
    (flash-error (format nil (_ "You are already logged in as: ~a")
                         (user-name)))
    (redirect "/")))

(defun user-exists-register-redirect ()
  "Tell the user that email address already is registered, and send them to the registration page."
  (progn
    (flash-error (_ "A user with that email is already registered."))
    (redirect "/user/register" 302)))

(defun login-redirect (email password &optional (target "/"))
  "Try to log in using HERMETIC::LOGIN, and display an appropriate message upon success.

TARGET may be set to the redirect target, and is provided from :REQUEST-PATH-INFO in *SESSION*."
  (handler-case
      (ratify:with-parsed-forms
          ((:email email)
           (:string password))
        (let ((params (list :|username| email :|password| password)))
          (login params
                 (progn
                   (flash-message (format nil (_ "Hello, ~a!")
                                          (user-name)))
                   (redirect target))
                 (progn
                   (flash-error (_ "Incorrect password."))
                   (redirect "/user/login"))
                 (progn
                   (flash-error (_ "No user corresponding to this email address."))
                   (redirect "/user/login")))))
    (ratify:combined-error (e)
      (flash-error e)
      (redirect "/user/login" 302))))

(defun register-new-user (name email password)
  "Try to register a new user by first SELECTing any matching USERs with EMAIL. If there is a match, use USER-EXISTS-REGISTER-REDIRECT.
Otherwise, create a new user, display the appropriate message, and redirect."
  (handler-case
      (ratify:with-parsed-forms
          ((:string name)
           (:string password)
           (:email email))
        (with-connection (db)
          (let ((found (mito:find-dao 'user :email email)))
            ;; Try to select this username, if a username is returned, the
            ;; user already exists, and display error.
            ;; 
            ;; Otherwise, create the user and add to the database.
            ;; Automatically direct to index.html on success.
            (if found
                (user-exists-register-redirect)
                (progn
                  (if (create-user name email password)
                      (progn
                        (flash-message (_ "Success! Please log in."))
                        (redirect "/user/login"))
                      (progn
                        (flash-message (_ "Something went wrong. Try again?"))
                        (redirect "/user/register"))))))))
    (ratify:combined-error (e)
      (flash-error e)
      (flash-error (_ "Something went wrong. Try again?"))
      (redirect "/user/register"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun render-user-list (&optional (tpl #P"user/index.html"))
  "Helper function. Display User Index page."
  (render-with-env tpl
                   `(:active "/user"
                     :user-list ,(select-dao 'user))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defroute ("/user" :method :GET) ()
  "User Settings Main Index Page."
  (with-logged-in-user
    (render-with-env #P"user/index.html"
                     `(:active "/user"))))

(defroute ("/user/login" :method :GET) ()
  "User Login Route - require the user to log in."
  ;; Always display the USER/LOGIN page
  (if (ignore-errors
       (logged-in-p))
      (already-logged-in-redirect)
      (render-with-env #P"user/login.html"
                       `(:active "/user"))))

(defroute ("/user/login" :method :POST) (&key _parsed)
  "User Login POST Route. We use HERMETIC:LOGGED-IN-P to do all the heavy lifting. LOGIN-REDIRECT does the redirect."
  (v:info :web "POST /user/login => ~a" _parsed)

  ;; (v:info :web "REQUEST-PATH-INFO: ~a SESSION-REQUEST-PATH-INFO: ~a"
  ;;         (lack.request:request-path-info *request*)
  ;;         (gethash :request-path-info *session*))

  (if (logged-in-p)
      (already-logged-in-redirect)
      (login-redirect (query-param "email" _parsed)
                      (query-param "password" _parsed)
                      (gethash :request-path-info *session*))))

;; TODO successmessage and errormessages
;; TODO POST /user/logout ? Currently just GET /user/logout will log you out :P
(defroute "/user/logout" ()
  "User Logout Route. GET request. Querying this from anywhere with the LACK.SESSION cookie set will trigger a logout and redirect."
  (logout
   (flash-message (_ "Logged out."))
   (flash-error (_ "You aren't logged in.")))
  (redirect "/" 302))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Register
;; TODO React To Session Cookie In default.html
;; Not sure what this is about^
(defroute ("/user/register" :method :GET) ()
  "User Registration Main Route. Registration required!"
  (let ((logged-in (logged-in-p)))
    (if logged-in
        (already-logged-in-redirect)
        (render-with-env #P"user/register.html"
                         `(:active "/user")))))

(defroute ("/user/register" :method :POST) (&key _parsed)
  "User Registration POST Route. REGISTER-NEW-USER does all the work."
  (v:info :web "POST /user/register => ~a" _parsed)

  (let ((logged-in (logged-in-p)))
    (if logged-in
        (already-logged-in-redirect)
        (register-new-user (query-param "name" _parsed)
                           (query-param "email" _parsed)
                           (query-param "password" _parsed)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defroute ("/user/:id/delete" :method :POST) (&key id)
  "User DELETE Route. ADMIN role only."
  (v:info :user "DELETE /user ~d" id)
  (handler-case
      (ratify:with-parsed-forms
          ((:integer id))
        (auth (:admin)
              (with-connection (db)
                (mito:delete-by-values 'user :id id)
                "")))
    (ratify:combined-error (e)
      (flash-error e))))

(defroute ("/user/:id/roles" :method :GET) (&key id)
  "User Roles Route. ADMIN role only."
  (auth (:admin)
        (format nil "~{~s~^ ~}"
                (mapcar #'name-of
                        (user-roles-of (find-dao 'user :id id))))))

(defroute ("/user/admin" :method :GET) ()
  "Main User List Route. ADMIN role only."
  (auth (:admin)
        (render-user-list #P"user/admin.html")))