;; (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-article-and-entry-table-check () (with-connection (db) (mito:ensure-table-exists '(user article entry)))) (defclass file() ((filename :col-type (or :null (:varchar 128)) :initarg :filename :accessor filename-of) (content-type :col-type (or :null (:varchar 32)) :initarg :content-type :accessor content-type-of)) #| USE OF MITO:DAO-TABLE-MIXIN (Chapter 13) =================================================================== Use 'table-mixin' to pull together data (I.E. database fields) from different tables. Database tables can be inherited in mito so you do no need a table for every structure you want to create/map between the source code and the database layer. |# (:metaclass mito:dao-table-mixin)) (defclass image (file)() ;; See note about dao-table-mixin above in 'file' class. (:metaclass mito:dao-table-mixin)) (defclass user (image) ; 'image' class defined below (chapter 13). ((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 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 (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))))))))) (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))) (defclass entry() ((user :col-type user :initarg :user :accessor author-of :reader author) (title :col-type (:varchar 200) :initarg :title :accessor title-of) (body :col-type (or :null :text) :initarg :body :accessor body-of) (date-posted :col-type :date :initarg :date-posted :accessor date-posted-of) (status :col-type (:varchar 16) :initarg :status :initform "draft")) (:metaclass mito:dao-table-class)) (defmethod initialize-instance :around((o entry) &rest args &key posted-year posted-month posted-day posted-hour posted-min date-posted &allow-other-keys) (apply #'call-next-method o `(,@ (when (and (null date-posted) posted-year) `(:date-posted ,(format nil "~A-~A-~AT~A:~A:00" posted-year posted-month posted-day posted-hour posted-min))) ,@args))) (defclass entry-image (image) ((entry :col-type entry :initarg :entry :accerror entry-of) (alt-text :col-type (:varchar 128) :initform "alt-text" :initarg :alt-text :accerror alt-text-of)) (:metaclass mito:dao-table-class)) (defmethod mito:delete-dao :before((user user)) (mito:delete-by-values 'entry :user-id (mito:object-id user))) (defun validate-entry (entry &rest target-slots) (with-check-validate (entry) ;target-slots) ((title (:require t) (:type string) (:assert (<= 1 (length title) 200))) (body (:require t)) (date-posted (:require t) (:key #'local-time:parse-timestring)) (status (:require t) (:assert (find status '("draft" "member-only" "public"):test #'equal)))))) ;;; Added in Chapter 13 ;; (defmethod validation:validate validation:validate ((image image) &key target-slots test) ;; (validation:with-check-validate (image ;; :target-slots target-slots ;; :test test) ((content-type ;; (:assert (find content-type #0='("image/jpeg" "image/png" "image/gif" "image/bmp") ;; :test #'equal) ;; "must be one of ~S but ~S" #0# content-type))))) ;; ;;; Reimplemented in Chapter 13. ;; (defmethod validation:validate validation:validate ((object entry-image) ;; &key target-slots test) ;; (validation:with-check-validate (object ;; :target-slots target-slots ;; :test test) ;; ((entry (:require t)) (filename (:require t))))) (defmethod validation-validate validation-validate ((image image) &key target-slots test) (with-check-validate (image) ;; :target-slots target-slots ;; :test test) ((content-type (:assert (find content-type #0='("image/jpeg" "image/png" "image/gif" "image/bmp") :test #'equal) "must be one of ~S but ~S" #0# content-type))))) ;;; Reimplemented in Chapter 13. (defmethod validation-validate validation-validate ((object entry-image) &key target-slots test) (break) (with-check-validate (object) ;; :target-slots target-slots ;; :test test) ((entry (:require t)) (filename (:require t))))) (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!" :filename (when (zerop x) "profile.png") :content-type (when (zerop x) "image/png"))) ;; "#.(" 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))) (dolist (name '("Jiro" "Taro" "Hana")) (let ((user (mito:find-dao 'user :name name))) (when user (dotimes (x 10) (mito:create-dao 'entry :user user :title (format nil "Title~D" x) :body body :date-posted (local-time:timestamp- now-time (- 10 x) :day) :status (nth (rem x 3) '("draft" "member-only" "public"))))))) ;; PROBLEM IS IN HERE.... (with-open-file (s (merge-pathnames #P"profile.png" rails-to-caveman.config::*application-root*) :element-type '(unsigned-byte 8)) (let ((vector (make-array (file-length s) :element-type '(unsigned-byte 8)))) (read-sequence vector s) (storage::write (make-instance 'flex::vector-input-stream :vector vector) 1 "account" (storage::make-file :name "profile.png" :content-type "image/png")) ;; PROBLEM IS IN HERE.... )))))) #| (defun seeds() (with-open-file (s (merge-pathnames "profile.png" your-app.config::*application-root*) :element-type '(unsigned-byte 8)) (let ((vector (make-array (file-length s) :element-type '(unsigned-byte 8)))) (read-sequence vector s) (storage::write (make-instance 'flex::vector-input-stream :vector vector) 1 "account" (storage::make-file :name "profile.png" :content-type "image/png")))) (let ((names #("Taro" "Jiro" "Hana" "John" "Mike" "Sophy" "Bill" "Alex" "Mary" "Tom")) ...) (with-connection (db) (dotimes (x 10) (mito:create-dao 'user :number (+ x 10) ... :password "asagao!" :filename (when(zerop x) "profile.png") :content-type (when(zerop x) "image/png") )) ...))) |# (defun rebuild () "Drops the current database table, recreates it and populates it using seeded data." (with-connection (db) (mapc #'mito:ensure-table-exists '(user article entry)) (mapc #'mito:recreate-table '(user article entry))) (seeds))