From c1b9559812245673ee342472afa4b0f69409a761 Mon Sep 17 00:00:00 2001 From: Craig Oates Date: Sat, 25 Dec 2021 22:16:15 +0000 Subject: [PATCH] Chapter 8 commit (authentication and Hermetic). There are some bugs within the code with this commit. The translation from Japanese to English is making it hard to follow along in some places. With that said, this repo. if for learning and becoming familiar with Caveman2, Common Lisp and the other things it comes with. --- rails-to-caveman.asd | 23 +- src/config.lisp | 3 +- src/locale.lisp | 51 +++ src/model.lisp | 325 +++++++++++++++--- src/view.lisp | 16 +- src/web.lisp | 568 ++++++++++++++++++++++--------- static/locale/ja-jp.lisp | 12 + templates/accounts/edit.html | 20 ++ templates/accounts/show.html | 15 + templates/index.html | 5 +- templates/layouts/app.html | 7 +- templates/passwords/edit.html | 34 ++ templates/shared/errors.html | 10 + templates/shared/header.html | 30 +- templates/shared/login_form.html | 29 +- templates/shared/sidebar.html | 2 + templates/shared/user_form.html | 18 + templates/users/body.html | 46 +++ templates/users/edit.html | 4 +- templates/users/form.html | 63 ++-- templates/users/index.html | 2 +- templates/users/new.html | 23 +- templates/users/show.html | 52 +-- 23 files changed, 1022 insertions(+), 336 deletions(-) create mode 100644 src/locale.lisp create mode 100644 static/locale/ja-jp.lisp create mode 100644 templates/accounts/edit.html create mode 100644 templates/accounts/show.html create mode 100644 templates/passwords/edit.html create mode 100644 templates/shared/errors.html create mode 100644 templates/shared/user_form.html create mode 100644 templates/users/body.html diff --git a/rails-to-caveman.asd b/rails-to-caveman.asd index c1e3b1c..067b578 100644 --- a/rails-to-caveman.asd +++ b/rails-to-caveman.asd @@ -10,6 +10,7 @@ #:cl-ppcre #:uiop #:local-time ; <-- Added Chapter 6 + #:ratify ; <-- Chapter 7 ;; for @route annotation #:cl-syntax-annot @@ -21,14 +22,18 @@ #:mito ; <--- Added in Chapter 4. #:datafly #:sxql + + ;; for authentication + #:hermetic ) - :components ((:module "src" - :components - ((:file "main" :depends-on ("config" "view" "db")) - (:file "web" :depends-on ("view")) - (:file "view" :depends-on ("config")) - (:file "db" :depends-on ("config")) - (:file "model" :depends-on ("db")) ; <--- Chapter 4. - (:file "config")))) - :description "" + :components + ((:module "src" + :components ((:file "main" :depends-on ("config" "view" "db")) + (:file "web" :depends-on ("view" "model")) + (:file "view" :depends-on ("config")) + (:file "db" :depends-on ("config")) + (:file "model" :depends-on ("db")) + (:file "locale" :depends-on ("config")) ; <--- This! + (:file "config")))) + :description "Rails to Caveman2 port." :in-order-to ((test-op (test-op "rails-to-caveman-test")))) diff --git a/src/config.lisp b/src/config.lisp index e406ad5..f6ad242 100644 --- a/src/config.lisp +++ b/src/config.lisp @@ -1,6 +1,7 @@ (in-package #:cl-user) (defpackage rails-to-caveman.config - (:use #:cl) + (:use #:cl + #:rails-to-caveman.locale) (:import-from #:envy #:config-env-var #:defconfig) diff --git a/src/locale.lisp b/src/locale.lisp new file mode 100644 index 0000000..ad68924 --- /dev/null +++ b/src/locale.lisp @@ -0,0 +1,51 @@ +(in-package #:cl-user) +(defpackage #:rails-to-caveman.locale + (:use #:cl) + (:export #:define-dictionary + #:with-i18n + #:accept-language + #:parse-accept-language + #:find-locale + #:find-acceptable-locale)) +(in-package #:rails-to-caveman.locale) + +(cl-locale:define-dictionary rails-to-caveman + ("ja" (merge-pathnames "locale/ja-jp.lisp" + rails-to-caveman.config:*static-directory*)) + ("ja-JP" (merge-pathnames "locale/ja-jp.lisp" + rails-to-caveman.config:*static-directory*))) + +(defmacro define-dictionary (name &rest args) + `(progn (cl-locale:define-dictionary ,name ,@args) + (defun reload () + (loop :for (locale dictionary) + :in (list ,@(mapcar (lambda (arg) + `(list ,@arg)) args)) + :do (cl-locale.core::register-dictionary ',name dictionary + :locale locale))))) + +(defmacro with-i18n ((dictionary locale) &body string-generate-form) + `(let ((cl-locale.core::*dictionary* + (cl-locale.core::ensure-dictionary ',dictionary)) + (cl-locale.core::*locale* ,locale)) + (cl-locale:i18n (progn ,@string-generate-form)))) + +(defun accept-language () + (and ningle:*request* (gethash "accept-langauge" + (getf (lack.request:request-env + ningle:*request*) :headers)))) + +(defun parse-accept-language (paremeter) + (mapcar #'car (sort (mapcar (lambda (param) + (ppcre:split ";q=" param)) + (ppcre:split #\, paremeter)) + #'> :key (lambda (x) + (read-from-string (or (cadr x) "1")))))) + +(defun find-locale (locale) + (and cl-locale.core::*dictionary* + (gethash locale cl-locale.core::*dictionary*))) + +(defun find-acceptable-locale (locales) + (find-if #'find-locale locales)) + diff --git a/src/model.lisp b/src/model.lisp index 33cc82e..747fffe 100644 --- a/src/model.lisp +++ b/src/model.lisp @@ -1,63 +1,69 @@ -(in-package #:cl-user) ; Not sure if this needs to exist (Chapter 4) -(defpackage #:rails-to-caveman.model +(in-package #:cl-user) +(defpackage rails-to-caveman.model (:use #:cl #:rails-to-caveman.db - #:mito)) + #:mito + #:local-time + #:ratify + #:ratify-types + #:cl-ppcre) + (:import-from #:ratify-types + #:parse-string + ) + (:export #:user + #:validate-user + #:seeds + #:rebuild + #:with-check-validate + #:administrator + #:email + #:full-name + #:id + #:name + #:sex)) (in-package #:rails-to-caveman.model) -;;; Defines the USER table class for the database. -;;; Will be used by mito (an ORM). -(defclass user () - ((number - :col-type - :integer - :initarg - :number - :reader number-of) +(defclass user() + ((number :col-type + :integer + :initarg + :number + :accessor number-of) (name :col-type (:varchar 64) :initarg :name - :reader name-of) - (full-name :col-type - (or (:varchar 128) :null) - :initarg - :full-name - :reader full-name-of) - (email :col-type - (or :null :text) + :accessor name-of) + (full-name + :col-type (or (:varchar 128) :null) + :initarg + :full-name + :accessor full-name-of) + (email :col-type (or :null :text) :initarg :email :accessor email-of) - (birthday :col-type - (or :null :date) + (birthday :col-type (or :null :date) :initarg :birthday - :reader birthday-of) + :accessor birthday-of) (sex :col-type :integer :initarg :sex - :initform 1 - :reader sex-of) - - #| CHANGED :ACCESSOR VALUE FROM TUTORIAL (CHAPTER 4) - =================================================== - The Chapter 4 tutorial has the :accessor value set to - 'administratorp'. Unfortunately, this causes initialisation - argument errors when trying to seed the database. To fix this, I - had to remove the 'p' part from that line. At the time of - writing, I do not know if that will have a negative effect on - future tutorials. - - I have left a note in the 'seeds' function below highlighting the - change to the :accessor value. - |# + :initform "1" ; <--- This! + :accessor sex-of) (administrator :col-type :boolean :initarg :administrator - :initform nil - :accessor administrator)) + :initform "1" ; as NIL. ; <--- This! + :accessor administrator-of) + (password :col-type + :text + :initarg + :password + :accessor password-of + :inflate #'cl-pass:hash )) (:metaclass mito:dao-table-class)) @@ -88,7 +94,8 @@ ;; seed the database (using 'seeds' ;; function. I have, also, left a note in the ;; 'user' class definition highlighting this. - :administrator (zerop 0)))))) + :administrator (zerop 0) + :password "asagao!"))))) (defun rebuild () @@ -109,3 +116,239 @@ this tutorial was translated/ported from." ;; constants and refer to them instead of passing hard coded 1 & 0. (defconstant +false+ 0) (defconstant +true+ 1) + +#| MACRO FOR VALIDATE-USER +========================== +At the time of writing, I have not got much experience writing +macros. So, the code below does not make much sense to me. I was part +of the tutorial in Chapter 7, though. So, I am not venturing off piste +here. + +The reason for this macro is reduce the amount of code needed for the +'validate-user' function. The tutorial provides two versions of the +'validate-user' function (I.E. macro and macro-less). I have commented +out the macro-less version of 'validate-user' and use the macro +version. I did not delete it because I wanted to keep it as a +reference for future projects. This is a learning project after all. +|# + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun canonicalize-assertions(assertions) + (mapcar (lambda(assert) + (etypecase(car assert) + (SYMBOL (cons (list (car assert)(car assert)) + (cdr assert))) + ((CONS (AND SYMBOL (NOT (OR KEYWORD BOOLEAN))) + (CONS (AND SYMBOL (NOT (OR KEYWORD BOOLEAN))) + NULL)) + (assert(every (lambda(clause) + (keywordp (car clause))) + (cdr assert))) assert))) assertions)) + (defun (var targets) + (alexandria:with-unique-names(slot name) + `(DOLIST(,slot (C2MOP:CLASS-SLOTS (CLASS-OF ,var))) + (LET((,name(C2MOP:SLOT-DEFINITION-NAME ,slot))) + (WHEN(OR (AND ,targets (FIND ,name ,targets) + (SLOT-BOUNDP ,var ,name) + (EQUAL "" (SLOT-VALUE ,var ,name))) + (AND (SLOT-BOUNDP ,var ,name) + (EQUAL "" (SLOT-VALUE ,var ,name)))) + (SLOT-MAKUNBOUND ,var ,name)))))) + (defun (clause g.obj g.alist) + (destructuring-bind((local-var slot-name) + . assertions)clause + `(CONS ',slot-name + ,( assertions g.obj slot-name g.alist local-var + (push-form-generator slot-name g.alist))))) + (defun parse-assertions(assertions) + (typecase (car assertions) + ((CONS (EQL :REQUIRE) + (CONS (EQL T)NULL)) + (values t (cdr assertions))) + ((CONS (EQL :REQUIRE) + (CONS NULL NULL)) + (values nil (cdr assertions))) + (T (values nil assertions)))) + (defun push-form-generator(slot-name alist) + (lambda(message) + `(push (cons ',slot-name ,message) ,alist))) + (defun (assertions g.obj slot-name g.alist local-var generator) + (multiple-value-bind(requirep assertions)(parse-assertions assertions) + `(LAMBDA() + (IF(SLOT-BOUNDP ,g.obj ',slot-name) + ,(let((form(make-form assertions g.alist local-var g.obj slot-name))) + (when form `(LET((,local-var (SLOT-VALUE ,g.obj ',slot-name))) + ,form))) + ,@(when requirep + (list (funcall generator "is required"))))))) + (defun make-form(assertions g.alist local-var g.obj slot-name) + (if(endp assertions) + nil + (apply #'spec-diverge g.alist slot-name g.obj local-var + (cdr assertions)(car assertions)))) + (defun (local-var spec-value rest g.alist g.obj slot-name generator format-arguments) + `(IF(TYPEP ,local-var ',spec-value) + ,(make-form rest g.alist local-var g.obj slot-name) + ,(funcall generator + (if format-arguments + `(format nil ,@format-arguments) + `(format nil "not type-of ~S" ',spec-value))))) + (defun (spec-value local-var g.obj slot-name rest g.alist generator format-arguments) + (let((v(gensym"CANONICALIZED")) + (c(gensym"CONDITION"))) + `(handler-case + (let((,v (funcall ,spec-value ,local-var))) + (setf (slot-value ,g.obj ',slot-name) + ,v ,local-var ,v) + ,(make-form rest g.alist local-var g.obj slot-name)) + (error(,c),(funcall generator + (if format-arguments + `(format nil ,@format-arguments) + `(princ-to-string ,c))))))) + (defun (spec-value rest g.alist local-var g.obj slot-name generator format-arguments) + `(if ,spec-value + ,(make-form rest g.alist local-var g.obj slot-name) + ,(funcall generator + (if format-arguments + `(format nil ,@format-arguments) + `(format nil "must satisfies ~S but ~S"' + ,spec-value ,local-var))))) + (defun + (g.obj spec-value rest g.alist local-var slot-name generator format-arguments) + `(UNLESS(MITO:OBJECT-ID ,g.obj) + (IF(NULL(MITO:SELECT-DAO + (CLASS-OF ,g.obj) + (SXQL:WHERE + ,spec-value) + (SXQL:LIMIT 1))) + ,(make-form rest g.alist local-var g.obj slot-name) + ,(funcall generator + (if format-arguments + `(format nil + ,@format-arguments) + "already exists"))))) + (defun spec-diverge + (g.alist slot-name g.obj local-var rest spec-key spec-value + &rest format-arguments) + (ecase spec-key + (:type ( local-var spec-value rest g.alist g.obj slot-name + (push-form-generator slot-name g.alist) + format-arguments)) + (:key ( spec-value local-var g.obj slot-name rest g.alist + (push-form-generator slot-name g.alist) + format-arguments)) + (:assert ( spec-value rest g.alist local-var g.obj slot-name + (push-form-generator slot-name g.alist) + format-arguments)) + (:unique ( g.obj spec-value rest g.alist local-var slot-name + (push-form-generator slot-name g.alist) + format-arguments))))) + + +(defmacro with-check-validate ((var) (&rest assertions)) + ;; initialize + (check-type var symbol) + (setf assertions + (mapcar + (lambda(assert) + (etypecase(car assert) + (symbol (cons (list (car assert) (car assert)) (cdr assert))) + ((cons (and symbol (not (or keyword boolean))) + (cons (and symbol (not (or keyword boolean))) null)) + (assert (every (lambda (clause) (keywordp (car clause))) + (cdr assert))) assert))) + assertions)) + (let ((alist (gensym"ALIST")) + (slot (gensym "SLOT")) (name (gensym"NAME"))) + ;; body + `(LET ((,alist)) + (dolist (,slot (c2mop:class-slots (class-of ,var))) + (let ((,name (c2mop:slot-definition-name ,slot))) + (when (and (slot-boundp ,var ,name) + (equal "" (slot-value ,var ,name))) + (slot-makunbound ,var ,name)))) + ,@(loop :for ((local-var slot-name) . assertions) :in assertions + :collect (labels((rec(assertions) + (if (endp assertions) + nil + (apply #'body (cdr assertions)(car assertions)))) + (body (rest key value &rest format-arguments) + (ecase key (:type `(if (typep ,local-var ',value) + ,(rec rest) + (push (cons ',slot-name + ,(if format-arguments + `(format nil + ,@format-arguments) + `(format nil + "is not type-of ~S"' + ,value))) + ,alist))) + (:key (let ((v(gensym"CANONICALIZED")) + (c (gensym"CONDITION"))) + `(handler-case (let ((,v (funcall ,value ,local-var))) + (setf (slot-value ,var ',slot-name) + ,v + ,local-var + ,v) + ,(rec rest)) + (error (,c) (push (cons ',slot-name (princ-to-string ,c)) + ,alist))))) + (:assert `(if ,value ,(rec rest) + (PUSH (CONS ',slot-name + ,(if format-arguments + `(format nil ,@format-arguments) + `(FORMAT NIL "must satisfies ~S but ~S" + ',value ,local-var))) + ,alist))) + (:unique `(unless(mito:object-id ,var) + (if (null (mito:select-dao + (class-of ,var) + (sxql:where ,value) + (sxql:limit 1))) + ,(rec rest) + (push + (cons + ',slot-name + "is already exists") + ,alist))))))) + (if (equal '(:require t) (car assertions)) + `(if (slot-boundp ,var ',slot-name) + (let ((,local-var + (slot-value ,var ',slot-name))) + ,(rec (cdr assertions))) + (push (cons ',slot-name ,"is required") ,alist)) + (progn (when (equal '(:require nil) + (car assertions)) + (pop assertions)) + `(if (slot-boundp ,var ',slot-name) + (let ((,local-var(slot-value ,var ',slot-name))) + ,(rec assertions))))))) + (values ,var (reverse ,alist))))) + + +(defun validate-user (user &rest target-slots) + (step + (with-check-validate (user) ; target-slots) + ((number (:require t) + (:key #'parse-integer) + (:assert (< 0 number 100)) + (:unique (:= :number number))) + (name (:require t) + (:type string) + (:assert (ppcre:scan "^[A-Za-z][A-Za-z0-9]*$" name)) + (:assert (<= 2 (length name) 20) "length must be (<= 2 x 20)") + (:unique (:like :name name))) + ((n full-name) + (:require t) + (:type string) + (:assert (<= 1 (length n) 20) "length must be (<= 1 x 20)")) + (email (:key #'ratify:test-email)) + ;; (password (:require t) + ;; (:type string) + ;; (:assert (< 0 (length password)) "Empty string is invalid")) + (birthday (:key #'local-time:parse-timestring)) + (sex (:require t) + (:key #'parse-integer) + (:assert (<= 1 sex 2))) + (administrator (:require t) + (:key (lambda(x) (zerop (parse-integer x))))))))) diff --git a/src/view.lisp b/src/view.lisp index ddd8eeb..f7e1fbc 100644 --- a/src/view.lisp +++ b/src/view.lisp @@ -1,6 +1,7 @@ (in-package #:cl-user) -(defpackage rails-to-caveman.view - (:use #:cl) +(defpackage #:rails-to-caveman.view + (:use #:cl + #:rails-to-caveman.locale) (:import-from #:rails-to-caveman.config #:*template-directory*) (:import-from #:caveman2 @@ -44,7 +45,8 @@ #:config #:appenv #:developmentp - #:productionp) + #:productionp + #:rails-to-caveman.locale) (:import-from #:caveman2 #:url-for) (:export #:title!) ; Added in Chapter 3 (Mockup section). @@ -52,6 +54,7 @@ ;; in-package and let code added in Chapter 3, also. This is ;; preperation for Switching Layout Templates section. (in-package #:rails-to-caveman.djula) ; Make sure this states your app name. + (let(title) (defun title! (&optional sub) (if sub @@ -68,3 +71,10 @@ ;;; project's TODOs. This filter is used in 'step13.html' (in ;;; /templates directory). (djula::def-filter :break(it) (cl-ppcre:regex-replace-all #\newline it "
")) + +(djula::def-filter :i18n(it) + (rails-to-caveman.locale::with-i18n + (rails-to-caveman.locale::rails-to-caveman + (rails-to-caveman.locale::find-acceptable-locale + (rails-to-caveman.locale::parse-accept-language + (rails-to-caveman.locale::accept-language)))) it)) diff --git a/src/web.lisp b/src/web.lisp index fc73d13..8752c66 100644 --- a/src/web.lisp +++ b/src/web.lisp @@ -1,5 +1,5 @@ (in-package #:cl-user) -(defpackage #:rails-to-caveman.web +(defpackage rails-to-caveman.web (:use #:cl #:caveman2 #:rails-to-caveman.config @@ -32,7 +32,9 @@ ;; to leave the code commented out. ;; '(:message "This is not a message") ; Added Chapter 3. - '(:numbers (1 2 3 4 5)) + `(:numbers (1 2 3 4 5) + :token ,(token)) + ;; :alert "Bitchin") )) (defroute "/users/index"() @@ -42,7 +44,7 @@ (sxql:order-by :number))) :token ,(token) :notice (flash-gethash - :notice ningle:*request*)))) + :notice ningle:*request*)))) (defroute "/users/search" (&key |q|) (render "users/index.html" @@ -72,9 +74,14 @@ (defroute "/user/new" () (render #P"users/new.html" - `(:users ,(with-connection (db) - (make-instance 'rails-to-caveman.model::user)) - :token ,(token)))) + `(:user ,(current-user) + :new-user ,(with-connection (db) + (rails-to-caveman.model::validate-user + (make-instance 'rails-to-caveman.model::user))) + :news (1 2 3 4 5) + :blogs (1 2 3 4 5) + ,@(roles) + :token ,(token)))) (defroute "/users/:id/edit" (&key id) (let* ((id (ignore-errors (parse-integer id))) @@ -82,102 +89,157 @@ (and id (mito:find-dao 'rails-to-caveman.model::user :id id))))) - (if user (render "users/edit.html" + (if user (render "accounts/edit.html" `(:user ,user :token ,(token))) (on-exception *web* 404)))) +#| (defroute ("/user/:id" :method :post) - (&key |authenticity-token| - id - (|number| "") - |name| - |full-name| - (|sex| "") - |birthday-year| - |birthday-month| - |birthday-day| - |email| - (|administrator| "")) - (if (not (string= |authenticity-token| (token))) - '(403 () ("Denied")) - (with-connection (db) - (let ((id (ignore-errors (parse-integer id))) - (user (and id - (mito:find-dao - 'rails-to-caveman.model::user :id id)))) - (if (null user) - '(500 () ("Could not edit because user doesn't exist."))) - (progn - - #| CHAPTER 6 CODE NOT WORKING HERE. - ================================= - - I could not get this part of the code (setf) to work when - following the tutorial. Because of this, I have decided to - leave the code the tutorial (in Chapter 6) - provided. Hopefully, there are other code examples which - will provide an answer to get this part of the code - working. - - For now, this route (I.E. when you try to update a user) the site will - throw an error and not update it. - |# - - (setf (rails-to-caveman.model::number-of user) (parse-integer |number| :junk-allowed t) - (rails-to-caveman.model::name-of user) |name| - (rails-to-caveman.model::full-name-of user) |full-name| - (rails-to-caveman.model::sex-of user) (parse-integer |sex| :junk-allowed t) - (rails-to-caveman.model::birthday-of user) (local-time:parse-timestring - (format nil "~A-~A-~A" - |birthday-year| - |birthday-month| - |birthday-day|)) - (rails-to-caveman.model::email-of user) |email| - (rails-to-caveman.model::administrator-of user) (eq rails-to-caveman.model::+true+ - (zerop (parse-integer - |administrator| - :junk-allowed t)))) - (mito:save-dao user) - (setf (gethash :notice ningle:*session*) "Updated") - `(303 (:location ,(format nil "/users/~D" id)))))))) - +(&key |authenticity-token| +id +(|number| "") +|name| +|full-name| +(|sex| "") +|birthday-year| +|birthday-month| +|birthday-day| +|email| +(|administrator| "")) +(if (not (string= |authenticity-token| (token))) +'(403 () ("Denied")) +(with-connection (db) +(let ((id (ignore-errors (parse-integer id))) +(user (and id +(mito:find-dao +'rails-to-caveman.model::user :id id)))) +(if (null user) +'(500 () ("Could not edit because user doesn't exist."))) +(progn + +#| CHAPTER 6 CODE NOT WORKING HERE. +================================= + +I could not get this part of the code (setf) to work when +following the tutorial. Because of this, I have decided to +leave the code the tutorial (in Chapter 6) +provided. Hopefully, there are other code examples which +will provide an answer to get this part of the code +working. + +For now, this route (I.E. when you try to update a user) the site will +throw an error and not update it. +|# + +;; (setf (rails-to-caveman.model::number-of user) (parse-integer |number| :junk-allowed t) +;; (rails-to-caveman.model::name-of user) |name| +;; (rails-to-caveman.model::full-name-of user) |full-name| +;; (rails-to-caveman.model::sex-of user) (parse-integer |sex| :junk-allowed t) +;; (rails-to-caveman.model::birthday-of user) (local-time:parse-timestring +;; (format nil "~A-~A-~A" +;; |birthday-year| +;; |birthday-month| +;; |birthday-day|)) +;; (rails-to-caveman.model::email-of user) |email| +;; (rails-to-caveman.model::administrator-of user) (eq rails-to-caveman.model::+true+ +;; (zerop (parse-integer +;; |administrator| +;; :junk-allowed t)))) +(mito:save-dao user) +(setf (gethash :notice ningle:*session*) "Updated") +`(303 (:location ,(format nil "/users/~D" id)))))))) +|# + +#| ROUTE/FUNCTION KEPT FOR REFERENCE (MACRO-LESS VERSION) +========================================================= +(defroute ("/user" :method :post) +(&key |authenticity-token| +(|number| "") +|name| +|full-name| +(|sex| "") +|birthday-year| +|birthday-month| +|birthday-day| +|email| +(|administrator| "")) +(if(not(string= |authenticity-token| (token))) +'(403 () ("Denied")) +(with-connection (db) +(let ((user (mito:create-dao +'rails-to-caveman.model::user +:number (parse-integer |number| :junk-allowed t) +:name |name| +:full-name |full-name| +:sex (parse-integer |sex| :junk-allowed t) +:birthday (local-time:parse-timestring +(format nil "~A-~A-~A" +|birthday-year| +|birthday-month| +|birthday-day|)) +:email |email| +:administrator (eq +rails-to-caveman.model::+true+ +(zerop +(parse-integer |administrator| +:junk-allowed t)))))) +(setf(gethash :notice ningle:*session*)"Stored!") +`(303 (:location ,(format +nil "/users/~D"(mito:object-id user)))))))) +|# + +;;; Macro-based version of route (validate-user). (defroute ("/user" :method :post) - (&key |authenticity-token| - (|number| "") - |name| - |full-name| - (|sex| "") - |birthday-year| - |birthday-month| - |birthday-day| - |email| - (|administrator| "")) - (if(not(string= |authenticity-token| (token))) - '(403 () ("Denied")) - (with-connection (db) - (let ((user (mito:create-dao - 'rails-to-caveman.model::user - :number (parse-integer |number| :junk-allowed t) - :name |name| - :full-name |full-name| - :sex (parse-integer |sex| :junk-allowed t) - :birthday (local-time:parse-timestring - (format nil "~A-~A-~A" - |birthday-year| - |birthday-month| - |birthday-day|)) - :email |email| - :administrator (eq - rails-to-caveman.model::+true+ - (zerop - (parse-integer |administrator| - :junk-allowed t)))))) - (setf(gethash :notice ningle:*session*)"Stored!") - `(303 (:location ,(format - nil "/users/~D"(mito:object-id user)))))))) + (&key method) + ;; (format t "~%[INFO] THIS IS THE ROUTE YOU THINK IT IS ~A" + ;; (lack.request:request-body-parameters + ;; ningle:*request*)) + (cond ((string= "put" method) (put-user + (lack.request:request-body-parameters + ningle:*request*))) + (t `(400 (:content-type "text/plain") + (,(format nil "Unknown method ~S" method)))))) + +(defroute put-user ("/user" :method :put) + (&rest args + &key + authenticity-token + birthday-year + birthday-month + birthday-day + number + name + full-name + email + administrator) + (declare (ignore number + name + full-name + email + administrator)) + (if (not (string= authenticity-token (token))) + `(403 (:content-type "text/plain") "Denied") + (multiple-value-bind (user errors) + (validate-user + (apply #'make-instance 'rails-to-caveman.model::user + ;; :birthday "2021-12-12" + ;; (format nil "~A-~A-~A" birthday-year birthday-month birthday-day) + :allow-other-keys t args)) + (if errors `(400 () + (,(render "users/new.html" + `(:user ,user + :errors ,errors + :token,(token))))) + (progn (setf(gethash :notice ningle:*session*)"Stored!") + `(303 (:location + ,(format + nil + "/users/~D" + (with-connection (db) + (mito:object-id user)))))))))) (defroute delete-user ("/users/:id" :method :delete) - (&key |authenticity-token| id) + (&key |authenticity-token| id) (if (not (string= |authenticity-token| (token))) `(403 (:content-type "text/plain") ("Denied")) (with-connection (db) @@ -194,67 +256,226 @@ (setf (gethash :notice ningle:*session* "Deleted.") `(303 (:location "/users/index"))))))))) -(defroute ("/users/:id" :method :post) - (&key |authenticity-token| - id - (|number| "") - |name| - |full-name| - (|sex| "") - |birthday-year| - |birthday-month| - |birthday-day| - |email| - (|administrator| "") - |_method|) - (if (not (string= |authenticity-token| (token))) - `(403 () ("Denied")) - (cond ((string= |_method| "delete") - (delete-user - (acons "ID" id (lack.request:request-body-parameters - ningle:*request*)))) - ((find |_method| `("" "post")) - (with-connection (db) - (let ((id (ignore-errors (parse-integer id))) - (user (and id (mito:find-dao - 'rails-to-caveman.model::user - :id id)))) - (if (null user) - '(500 (:content-type "text/plan" - ("Could not find the user.")) - (progn (setf (rails-to-caveman.model::number-of user) - (parse-integer |number| :junk-allowed t) - (rails-to-caveman.model::name-of user) - |name| - (rails-to-caveman.model::full-name-of user) - (rails-to-caveman.model::sex-of user) - (parse-integer |sex| :junk-allowed t) - (rails-to-caveman.model::birthday-of user) - (local-time:parse-timestring - (format nil "~A-~A-~A" - |birthday-year| - |birthday-month| - |birthday-day|)) - (rails-to-caveman.model::email-of user) - |email| - (rails-to-caveman.model::administrator user) - (eq rails-to-caveman.model::+true+ - (zerop (parse-integer - |administrator| - :junk-allowed t)))) - (mito:save-dao user) - (setf (gethash - :notice ningle:*session*) - "Updated") - `(303 (:location ,(format nil - "/users/~D" - id))))))))) - (t `(400 (:content-type "text/plain") - (,(format nil "Unsupported method ~S" - |_method|))))))) - - - +(defroute ("/user/:id" :method :post) + (&key id method) + (cond ((string= method "delete") + (delete-user + (acons "ID" id + (lack.request:request-body-parameters ningle:*request*)))) + ((find method '("" "post" nil) :test #'equal) + (post-user (acons "id" + id + (lack.request:request-body-parameters ningle:*request*)))) + (t `(400 (:content-type "text/plain") + (,(format nil "Unsupported method ~S" method)))))) + +;;; YOU ARE UP TO HERE: +;;; CAN'T GET THE VALIDATION TO WORK WHEN CREATING A NEW ACCOUNT. +(defun post-user(request) + (format t "[INFO] You have reached post-user request") + (destructuring-bind + (&key + authenticity-token + id + number + name + full-name + sex + birthday-year + birthday-month + birthday-day + email + administrator + &allow-other-keys) + (with-connection (db) + (loop :for (key . value) + :in request + :collect (let((*package*(find-package :keyword))) + (read-from-string key)) + :collect value) + (if (not (string= authenticity-token (token))) + `(403 () ("Denied")) + (let* ((id (ignore-errors (parse-integer id))) + (user (and id + (mito:find-dao 'rails-to-caveman.model::user :id id)))) + (if (null user) + `(500 (:content-type "text/plain") + ("Could not edit exists user.")) + (progn (setf (rails-to-caveman.model::number-of user) number + (rails-to-caveman.model::name-of user) name + (rails-to-caveman.model::full-name-of user) full-name + (rails-to-caveman.model::sex-of user) sex + (rails-to-caveman.model::birthday-of user) "2021-12-21" + ;; (format nil + ;; "~A-~A-~A" + ;; birthday-year + ;; birthday-month + ;; birthday-day) + (rails-to-caveman.model::email-of user) email + (rails-to-caveman.model::administrator-of user) administrator) + (multiple-value-bind (user errors) + (rails-to-caveman.model::validate-user user)) + (if errors + `(400 ()(,(render "user/edit.html" + `(:user ,user + :errors ,errors + :token ,(token))))) + (progn (mito:save-dao user) + (setf (gethash :notice ningle:*session*)"Updated") + `(303 (:location + ,(format nil "/user/~D" id)))))))))))) + +(defroute "/account" () + (if (not (hermetic:logged-in-p)) + '(401 ()) + (render "users/show.html" + `(:user ,(current-user) + :news (1 2 3 4 5) + :blogs (1 2 3 4 5) ,@(roles) + :token ,(token))))) + + +(defroute "/account/new"() ) + +(defroute "/account/edit" () + (if (not (hermetic:logged-in-p)) + '(401 ()) + (render "accounts/edit.html" + `(:token ,(token) + :user ,(current-user) + :news (1 2 3 4 5) + :blogs (1 2 3 4 5) + ,@(roles))))) + +(defroute("/account" :method :post) + (&key number + name + full-name + sex + birthday-year + birthday-month + birthday-day + email + (administrator "1") + authenticity-token) + (if (not (string= authenticity-token (token))) + '(403 (:content-type "text/plain") ("Denied")) + (if (not (hermetic:logged-in-p)) + '(401 ()) + (let* ((user (current-user))) + (setf (rails-to-caveman.model::number-of user) number + (rails-to-caveman.model::name-of user) name + (rails-to-caveman.model::full-name-of user) full-name + (rails-to-caveman.model::sex-of user) sex + (rails-to-caveman.model::birthday-of user) + (format nil "~A~A~A" birthday-year + birthday-month + birthday-day) + (rails-to-caveman.model::email-of user) email + (rails-to-caveman.model::administrator-of user) administrator + (rails-to-caveman.model::password-of user) + (gethash :password ningle:*session*)) + (multiple-value-bind (user errors) + (rails-to-caveman.model::validate-user user) + (if errors + `(400 () + (,(render "accounts/edit.html" + `(:user ,user + :errors ,errors + :news (1 2 3 4 5) + :blogs (1 2 3 4 5) + ,@(roles) + :token ,(token))))) + (progn (with-connection (db) + (mito:save-dao user) + (setf (gethash :notice ningle:*session*) + "Updated") + '(303 (:location "/account")))))))))) + +(defroute("/account" :method :put)() ) +(defroute("/account" :method :delete)() ) + +(defroute "/password" () ; as show + (if (not (hermetic:logged-in-p)) + '(401 ()) + '(303 (:location "/account")))) + +(defroute "/password/edit" () + (if (not (hermetic:logged-in-p)) + '(401 ()) + (render "passwords/edit.html" + `(:token ,(token))))) + +(defroute ("/password" :method :post) (&key old new confirmation authenticity-token) + (if (not (hermetic:logged-in-p)) + '(403 (:content-type "text/plain")("Denied")) + (let*((user(current-user)) + (render-args `(:user ,user :token ,(token) + :news (1 2 3 4 5) + :blogs (1 2 3 4 5)))) + (if (not (string= authenticity-token(token))) + `(403 (:content-type "text/plain") ("Denied")) + (if (equal "" old) + (render "password/edit.html" + (list* :errors '((current-password . "is required")) + render-args)) + (if (not + (cl-pass:check-password old (rails-to-caveman.model::password-of user))) + (render "passwords/edit.html" + (list* :errors '((password . "is not correct")) render-args)) + (if (not (equal new confirmation)) + (render "passwords/edit.html" + (list* :errors '((confirmation . "is failed")) + render-args)) + (progn (setf (rails-to-caveman.model::password-of user) new) + (multiple-value-bind (user errors) + (rails-to-caveman.model::validate-user user + 'rails-to-caveman.model::password) + (if errors + (render "passwords/edit.html" + (list* :errors errors render-args)) + (progn (mito:save-dao user) + (setf (gethash :notice ningle:*session*) "Password is changed") + '(303 (:location "/account"))))))))))))) + +(defroute ("/session" :method :post) (&key method) + (cond ((string= "delete" method) + (logout (lack.request:request-body-parameters ningle:*request*))) + ((string= "post" method) + (post-session (lack.request:request-body-parameters ningle:*request*))) + (t `(400 (:content-type "text/plain") + (,(format nil "Unknown method ~S" method)))))) + +(defun post-session (request) + (destructuring-bind + (&key name password authenticity-token &allow-other-keys) + (request-params request) + (if (not (string= authenticity-token (token))) + `(403 (:content-type "text/plain") ("Denied")) + (let ((params (list :|username| name + :|password| password))) + (format t "You look like you have logged in") + (hermetic:login params + (progn (with-connection (db) + (setf + (gethash :id ningle:*session*) (mito:object-id + (mito:find-dao + 'rails-to-caveman.model::user + :name name)) + (gethash :password ningle:*session*) password)) + '(303 (:location "/"))) + (progn (setf (gethash :alert ningle:*session*) "Name and password don't match.") + '(303 (:location "/"))) + (progn (setf (gethash :alert ningle:*session*) "No such user") + '(303 (:location "/")))))))) + +(defroute logout ("/session" :method :delete) (&key authenticity-token) + (if (not (string= authenticity-token (token))) + `(403 (:content-type "text/plain") ("Denied")) + (hermetic::logout (progn (flash-gethash :id ningle:*session*) + '(303 (:location "/"))) + '(303 (:location "/"))))) + (defroute "/about" () ;; about.html should be in the /templates directory. @@ -410,6 +631,7 @@ (let ((value (gethash key table))) (remhash key table) value)) + ;; ;; Error pages @@ -417,3 +639,37 @@ (declare (ignore app)) (merge-pathnames #P"_errors/404.html" *template-directory*)) + +(hermetic:setup :user-p (lambda (name) + (with-connection (db) + (mito:find-dao + 'rails-to-caveman.model::user :name name))) + :user-pass (lambda (name) + (rails-to-caveman.model::password-of + (with-connection (db) + (mito:find-dao 'rails-to-caveman.model::user :name name)))) + :user-roles (lambda (name) + (cons :logged-in + (let ((user (with-connection (db) + (mito:find-dao 'rails-to-caveman.model::user :name name)))) + (and user (rails-to-caveman.model::administrator-of user) + '(:administrator))))) + :session ningle:*session* + :denied (constantly '(400 (:content-type "text/plain") ("Authenticate denied")))) + +(defun request-params (request) + (loop :for (key . value) :in request + :collect (let ((*package* (find-package :keyword))) + (read-from-string key)) + :collect value)) + +(defun roles() + (loop :for role :in (hermetic:roles) + :collect role + :collect t)) + +(defun current-user () + (with-connection (db) + (mito:find-dao + 'rails-to-caveman.model::user + :id (gethash :id ningle:*session*)))) diff --git a/static/locale/ja-jp.lisp b/static/locale/ja-jp.lisp new file mode 100644 index 0000000..b9917bd --- /dev/null +++ b/static/locale/ja-jp.lisp @@ -0,0 +1,12 @@ +(("hello" . "(=ﾟωﾟ)ﾉぃょぅ") + ("Number" . "背番号") + ("Name" . "ユーザー名") + ("Full Name" . "氏名") + ("Sex" . "性別") + ("Male" . "男") + ("Female" . "女") + ("Birthday" . "誕生日") + ("Email" . "メールアドレス") + ("Administrator" . "管理者") + ("Create user" . "登録する") + ("is required" . "を入力してください。")) diff --git a/templates/accounts/edit.html b/templates/accounts/edit.html new file mode 100644 index 0000000..433057e --- /dev/null +++ b/templates/accounts/edit.html @@ -0,0 +1,20 @@ +{% extends "layouts/app.html" %} +{% block title %} +{% lisp (title! "Edit account info") %} +{% endblock %} + +{% block content %} +

{% lisp (title!) %}

+ +
+ Go back my account +
+ + +{% endblock %} diff --git a/templates/accounts/show.html b/templates/accounts/show.html new file mode 100644 index 0000000..dbea66b --- /dev/null +++ b/templates/accounts/show.html @@ -0,0 +1,15 @@ +{% extends "layouts/app.html" %} +{% block title %} +{% lisp (title! "My account") %} +{% endblock %} + +{% block content %} +

{% lisp (title!) %}

+ + + +{% include "user/body.html" %} +{% endblock %} diff --git a/templates/index.html b/templates/index.html index 0c24cb0..8a0da31 100644 --- a/templates/index.html +++ b/templates/index.html @@ -20,9 +20,12 @@ no guarantee it will contain anything n it, though. -->

{{ message }}

- {% for b in numbers %}
  • Blog Header
    • {% endfor %} + +{% if alert %} +

    {{alert}}

    +{% endif %} {% endblock %} diff --git a/templates/layouts/app.html b/templates/layouts/app.html index 08b7f17..7050be3 100644 --- a/templates/layouts/app.html +++ b/templates/layouts/app.html @@ -17,9 +17,10 @@ {% block content %}{% endblock %}