( 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-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 )
( 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!" ) ) ) ) )
( defun rebuild ( )
"Drops the current database table, recreates it and populates it using seeded data."
( with-connection ( db )
( mito:recreate-table 'user ) )
( 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 ) ) ) ) ) ) ) ) )