You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
439 lines
14 KiB
439 lines
14 KiB
;; (in-package #:cl-user) |
|
(defpackage #:rails-to-caveman.model |
|
(:use #:cl |
|
#:rails-to-caveman.db |
|
#:mito |
|
#:local-time) |
|
;; #:ratify |
|
;; #:ratify-types) |
|
;; #:cl-ppcre) |
|
(:import-from #:ratify |
|
#:test-email) |
|
;; (:import-from #:cl-ppcre |
|
;; #:parse-string) |
|
(:export #:user |
|
#:validate-user |
|
#:seeds |
|
#:rebuild |
|
#:with-check-validate |
|
#:administrator |
|
#:email |
|
#:full-name |
|
#:id |
|
#:name |
|
#:sex)) |
|
(in-package #:rails-to-caveman.model) |
|
|
|
(defclass article () |
|
((title :initarg :title |
|
:col-type (:varchar 80) |
|
:accessor title-of) |
|
(body :initarg :body |
|
:col-type :text |
|
:accessor body-of) |
|
(date-released :initarg :date-released |
|
:col-type :date |
|
:accessor date-released-of) |
|
(date-expired :initarg :date-expired |
|
:col-type (or :null :date) |
|
:accessor date-expired-of) |
|
(member-only :initarg :member-only |
|
:col-type :boolean |
|
:initform "1" ; as NIL |
|
:accessor member-only)) |
|
(:metaclass mito:dao-table-class)) |
|
|
|
(defun user-and-article-table-check () |
|
(with-connection (db) |
|
(mito:ensure-table-exists 'user) |
|
(mito:ensure-table-exists 'article))) |
|
|
|
|
|
(defclass user () |
|
((number :col-type :integer |
|
:initarg :number |
|
:accessor number-of) |
|
(name :col-type (:varchar 64) |
|
:initarg :name |
|
: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) |
|
:initarg :birthday |
|
:accessor birthday-of) |
|
(sex :col-type :integer |
|
:initarg :sex |
|
:initform "1" ; <--- This! |
|
:accessor sex-of) |
|
(administrator :col-type :boolean |
|
:initarg :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)) |
|
|
|
|
|
(defun seeds() |
|
;; '#(' are ARRAY LITERALS. I keep forgetting this and need to look |
|
;; it up. |
|
(let ((names |
|
#("Taro" "Jiro" "Hana" "John" "Mike" "Sophy" "Bill" "Alex" "Mary" "Tom")) |
|
(fnames ; First Names |
|
#("Hippo" "Darling" "Lopez" "Jerry")) |
|
(gnames ; Given Names |
|
#("Orange" "Fox" "Snake"))) |
|
(with-connection (db) |
|
(dotimes (x 10) |
|
(mito:create-dao 'user |
|
:number (+ x 10) |
|
:name (aref names x) |
|
:full-name (format nil "~A ~A" |
|
(aref fnames (rem x 4)) |
|
(aref gnames (rem x 3))) |
|
:email (format nil "~A@example.com" (aref names x)) |
|
:birthday "1981-12-01" |
|
:sex (nth (rem x 3) '(1 1 2)) |
|
;; Removed 'p' from end of :administrator -- |
|
;; so the code differs from the code in the |
|
;; tutorial (Chapter 4). I had to change it |
|
;; because it produced errors when trying to |
|
;; seed the database (using 'seeds' |
|
;; function. I have, also, left a note in the |
|
;; 'user' class definition highlighting this. |
|
:administrator (zerop 0) |
|
:password "asagao!")) |
|
;; "#.(" is an ARRAY LITERAL. (Noted in 'Loving Common Lisp' book). |
|
(let ((body #.(with-output-to-string (*standard-output*) |
|
(format t "Morning glory wins.~2%") |
|
(write-line "hgoe hoge boge hoge") |
|
(write-line "fuga fuga guffaug uga") |
|
(write-line "tasdf asdf asdf sadf"))) |
|
(now-time (local-time:now))) |
|
(dotimes (x 10) |
|
(mito:create-dao 'article |
|
:title (format nil "Result:~D" x) |
|
:body body |
|
:date-released (local-time:timestamp- now-time (- 8 x) :day) |
|
:date-expired (local-time:timestamp- now-time (- 2 x) :day) |
|
:member-only (zerop 0))))))) |
|
|
|
|
|
(defun rebuild () |
|
"Drops the current database table, recreates it and populates it using seeded data." |
|
(with-connection (db) |
|
(mito:recreate-table 'user) |
|
(mito:recreate-table 'article)) |
|
(seeds)) |
|
|
|
(defun ids () |
|
"Produces a list of all the Id's in the database. Part of Chapter 4 |
|
tutorial and is a port of the 'ids method' in the Ruby on Rails book |
|
this tutorial was translated/ported from." |
|
(rails-to-caveman.db:with-connection (rails-to-caveman.db:db) |
|
(mapcar #'mito:object-id |
|
(mito:retrieve-dao 'rails-to-caveman.model::user)))) |
|
|
|
;; A common strategy to deal with SQLite Boolean types is to set |
|
;; 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 <initialize-slots>(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 <spec-pair>(clause g.obj g.alist) |
|
(destructuring-bind((local-var slot-name) |
|
. assertions)clause |
|
`(CONS ',slot-name |
|
,(<spec-function> 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 <spec-function>(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 <type-spec-body>(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 <key-spec-body>(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 <assert-spec-body>(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 <unique-spec-body> |
|
(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 (<type-spec-body> local-var spec-value rest g.alist g.obj slot-name |
|
(push-form-generator slot-name g.alist) |
|
format-arguments)) |
|
(:key (<key-spec-body> spec-value local-var g.obj slot-name rest g.alist |
|
(push-form-generator slot-name g.alist) |
|
format-arguments)) |
|
(:assert (<assert-spec-body> spec-value rest g.alist local-var g.obj slot-name |
|
(push-form-generator slot-name g.alist) |
|
format-arguments)) |
|
(:unique (<unique-spec-body> 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))))))))) |
|
|
|
(defun validate-article (article &rest target-slots) |
|
(with-check-validate (article) ; target-slots) |
|
((title (:require t) |
|
(:type string) |
|
(:assert (<= (length title) 80))) |
|
(body (:require t) |
|
(:type string) |
|
(:assert (<= (length body) 2000))) |
|
(date-released (:require t) |
|
(:key #'local-time:parse-timestring)) |
|
(date-expired (:key #'local-time:parse-timestring) |
|
(:assert (local-time:timestamp< |
|
(date-released-of article) |
|
date-expired) |
|
"Date expired too old")) |
|
(member-only (:require t) |
|
(:key (lambda(x)(zerop(parse-integer x)))))))) |
|
|
|
(defmethod initialize-instance |
|
:around ((o article) |
|
&rest args |
|
&key date-released |
|
released-year |
|
released-month |
|
released-day |
|
released-hour |
|
released-min |
|
date-expiration |
|
expired-year |
|
expired-month |
|
expired-day |
|
expired-hour |
|
expired-min |
|
no-expiration-p |
|
&allow-other-keys) |
|
(apply #'call-next-method o |
|
`(,@ (when (and (null date-released) released-year) |
|
`(:date-released |
|
,(format nil "~A-~A-~AT~A:~A:00" |
|
released-year |
|
released-month |
|
released-day |
|
released-hour |
|
released-min))) |
|
,@(when (and (not no-expiration-p) |
|
(null date-expiration) |
|
expired-year) |
|
`(:date-expired |
|
,(format nil "~A-~A-~AT~A:~A:00" |
|
expired-year |
|
expired-month |
|
expired-day |
|
expired-hour |
|
expired-min))) |
|
,@args)))
|
|
|