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