lispy-education
/
rails-to-caveman
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
A website built in Common Lisp using Caveman2 as its framework. It is based on a collection of tutorials written by hyotang666. Those tutorials are based on chapters from the book 'Basic Ruby on Rails'. hyotang666 ported the Ruby code to Common Lisp.
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.
24 Commits
1 Branch
0 Tags
663 KiB
 
 
 
 
Tree: 96b28bc915
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '96b28bc915'
${ noResults }
rails-to-caveman/src/model.lisp

606 lines
20 KiB
Raw Blame History

;; (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 <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)))
(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))