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 %}