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/web.lisp

1728 lines
58 KiB
Raw Blame History

;; (in-package #:cl-user)
(defpackage #:rails-to-caveman.web
(:use #:cl
#:caveman2
#:rails-to-caveman.config
#:rails-to-caveman.view
#:rails-to-caveman.model
#:sxql
#:mito
#:rails-to-caveman.storage
#:cl-who
;; #:rails-to-caveman.helpers
#:status-code)
;; #:rfc2616-sec10)
(:import-from #:rails-to-caveman.db
#:connection-settings
#:db
#:with-connection)
(:export #:*web*))
(in-package #:rails-to-caveman.web)
;; for @route annotation
(syntax:use-syntax :annot)
;;
;; Application
(defclass <web> (<app>) ())
(defvar *web* (make-instance '<web>))
(clear-routing-rules *web*)
;;
;; Routing rules
(defroute "/" ()
"Top page"
(let ((articless (articles-make 5)))
(format t "[INFO] ~a" articless)
(render #P"index.html" `(:notice ,(flash-gethash :notice ningle:*session*)
:user,(when (hermetic:logged-in-p) (current-user))
,@(roles)
:token ,(token)
:alert ,(flash-gethash :alert ningle:*session*)
:news ,articless
:blogs (1 2 3 4 5)
:articles ,articless))))
(defroute "/users/index"()
(render "users/index.html"
`(:users ,(with-connection (db)
(mito:select-dao 'rails-to-caveman.model::user
(sxql:order-by :number)))
:token ,(token)
:notice (flash-gethash
:notice ningle:*request*))))
(defroute "/users/search" (&key |q|)
(render "users/index.html"
`(:users ,(with-connection (db)
(mito:select-dao 'rails-to-caveman.model::user
(sxql:where
`(:or (:like :name ,|q|)
(:like :full-name ,|q|)))
(sxql:order-by :number))))))
(defroute "/users/:id" (&key id)
(let ((id (ignore-errors (parse-integer id))))
(if (null id)
(myway.mapper:next-route)
(let ((user (with-connection (db)
(mito:find-dao 'rails-to-caveman.model::user
:id id))))
;; (setf id (parse-integer id))
(if user
(render "users/show.html"
`(:user ,(with-connection (db)
(mito:find-dao 'rails-to-caveman.model::user
:id id))
:notice ,(flash-gethash
:notice ningle:*session*)))
(on-exception *web* 404))))))
(defroute "/user/new" ()
(render #P"users/new.html"
`(:user ,(current-user)
:new-user ,(with-connection (db)
(rails-to-caveman.model::validate-user
(make-instance 'rails-to-caveman.model::user)))
:news (1 2 3 4 5)
:blogs (1 2 3 4 5)
,@(roles)
:token ,(token))))
(defroute "/users/:id/edit" (&key id)
(let* ((id (ignore-errors (parse-integer id)))
(user (with-connection (db) ; NOTE `USER' AND NOT USERS.
(and id
(mito:find-dao 'rails-to-caveman.model::user
:id id)))))
(if user (render "accounts/edit.html"
`(:user ,user :token ,(token)))
(on-exception *web* 404))))
#|
(defroute ("/user/:id" :method :post)
(&key |authenticity-token|
id
(|number| "")
|name|
|full-name|
(|sex| "")
|birthday-year|
|birthday-month|
|birthday-day|
|email|
(|administrator| ""))
(if (not (string= |authenticity-token| (token)))
'(403 () ("Denied"))
(with-connection (db)
(let ((id (ignore-errors (parse-integer id)))
(user (and id
(mito:find-dao
'rails-to-caveman.model::user :id id))))
(if (null user)
'(500 () ("Could not edit because user doesn't exist.")))
(progn
#| CHAPTER 6 CODE NOT WORKING HERE.
=================================
I could not get this part of the code (setf) to work when
following the tutorial. Because of this, I have decided to
leave the code the tutorial (in Chapter 6)
provided. Hopefully, there are other code examples which
will provide an answer to get this part of the code
working.
For now, this route (I.E. when you try to update a user) the site will
throw an error and not update it.
|#
;; (setf (rails-to-caveman.model::number-of user) (parse-integer |number| :junk-allowed t)
;; (rails-to-caveman.model::name-of user) |name|
;; (rails-to-caveman.model::full-name-of user) |full-name|
;; (rails-to-caveman.model::sex-of user) (parse-integer |sex| :junk-allowed t)
;; (rails-to-caveman.model::birthday-of user) (local-time:parse-timestring
;; (format nil "~A-~A-~A"
;; |birthday-year|
;; |birthday-month|
;; |birthday-day|))
;; (rails-to-caveman.model::email-of user) |email|
;; (rails-to-caveman.model::administrator-of user) (eq rails-to-caveman.model::+true+
;; (zerop (parse-integer
;; |administrator|
;; :junk-allowed t))))
(mito:save-dao user)
(setf (gethash :notice ningle:*session*) "Updated")
`(303 (:location ,(format nil "/users/~D" id))))))))
|#
#| ROUTE/FUNCTION KEPT FOR REFERENCE (MACRO-LESS VERSION)
=========================================================
(defroute ("/user" :method :post)
(&key |authenticity-token|
(|number| "")
|name|
|full-name|
(|sex| "")
|birthday-year|
|birthday-month|
|birthday-day|
|email|
(|administrator| ""))
(if(not(string= |authenticity-token| (token)))
'(403 () ("Denied"))
(with-connection (db)
(let ((user (mito:create-dao
'rails-to-caveman.model::user
:number (parse-integer |number| :junk-allowed t)
:name |name|
:full-name |full-name|
:sex (parse-integer |sex| :junk-allowed t)
:birthday (local-time:parse-timestring
(format nil "~A-~A-~A"
|birthday-year|
|birthday-month|
|birthday-day|))
:email |email|
:administrator (eq
rails-to-caveman.model::+true+
(zerop
(parse-integer |administrator|
:junk-allowed t))))))
(setf(gethash :notice ningle:*session*)"Stored!")
`(303 (:location ,(format
nil "/users/~D"(mito:object-id user))))))))
|#
;;; Macro-based version of route (validate-user).
(defroute ("/user" :method :post)
(&key method)
;; (format t "~%[INFO] THIS IS THE ROUTE YOU THINK IT IS ~A"
;; (lack.request:request-body-parameters
;; ningle:*request*))
(cond ((string= "put" method) (put-user
(lack.request:request-body-parameters
ningle:*request*)))
(t `(400 (:content-type "text/plain")
(,(format nil "Unknown method ~S" method))))))
(defroute put-user ("/user" :method :put)
(&rest args
&key
authenticity-token
birthday-year
birthday-month
birthday-day
number
name
full-name
email
administrator)
(declare (ignore number
name
full-name
email
administrator))
(if (not (string= authenticity-token (token)))
`(403 (:content-type "text/plain") "Denied")
(multiple-value-bind (user errors)
(validate-user
(apply #'make-instance 'rails-to-caveman.model::user
;; :birthday "2021-12-12"
;; (format nil "~A-~A-~A" birthday-year birthday-month birthday-day)
:allow-other-keys t args))
(if errors `(400 ()
(,(render "users/new.html"
`(:user ,user
:errors ,errors
:token,(token)))))
(progn (setf(gethash :notice ningle:*session*)"Stored!")
`(303 (:location
,(format
nil
"/users/~D"
(with-connection (db)
(mito:object-id user))))))))))
(defroute delete-user ("/users/:id" :method :delete)
(&key |authenticity-token| id)
(if (not (string= |authenticity-token| (token)))
`(403 (:content-type "text/plain") ("Denied"))
(with-connection (db)
(let* ((id (ignore-errors (parse-integer id)))
(user (and id
(mito:find-dao 'rails-to-caveman.model::user
:id id))))
(if (null user)
`(500 (:content-type "text-plain")
(,(format nil
"~%Could not delete. User doesn't exist. Id ~S"
id)))
(progn (mito:delete-dao user)
(setf (gethash :notice ningle:*session* "Deleted.")
`(303 (:location "/users/index")))))))))
;; Replaced in Chapter 13.
;; (defroute ("/user/:id" :method :post)
;; (&key id method)
;; (cond ((string= method "delete")
;; (delete-user
;; (acons "ID" id
;; (lack.request:request-body-parameters ningle:*request*))))
;; ((find method '("" "post" nil) :test #'equal)
;; (post-user (acons "id"
;; id
;; (lack.request:request-body-parameters ningle:*request*))))
;; (t `(400 (:content-type "text/plain")
;; (,(format nil "Unsupported method ~S" method))))))
;; Reimplemented in Chapter 13.
(defroute ("/user/:id" :method :post)
(&key id method)
(method-case (alexandria:ensure-car method)
("delete" (delete-user
(acons "ID" id
(lack.request:request-body-parameters ningle:*request*))))
("post"
(update-user
(acons "ID" id
(lack.request:request-body-parameters ningle:*request*))))))
(defun update-user (request)
(destructuring-bind (&rest args &key
authenticity-token
id
number
name
full-name
sex
email
administrator
image
birthday-year
birthday-month
birthday-day
&allow-other-keys)
(request-params request)
(declare (ignore
number
name
full-name
sex
email
administrator
birthday-year
birthday-month
birthday-day))
(with-authenticity-check ((:token (car authenticity-token)))
(ensure-let ((old (mito:find-dao 'rails-to-caveman.model::user :id id)))
(let ((file (rails-to-caveman.model::filename-of old)))
(multiple-value-bind (user errors)
(validation-validate
(apply #'rails-to-caveman.model::update-instance old
:image image
`(,@(mapcar #'alexandria:ensure-car args)
:administrator "1")))
(if errors (render "user/edit.html"
`(,@(roles)
:news ,(articles 5)
:blogs ,(entries :limit 5)
:user ,user
:token ,(token)
:errors ,errors))
(progn (mito:save-dao user)
(unless (equal file
(ignore-errors (rails-to-caveman.model::filename-of user)))
(rails-to-caveman.model::purge user "account" file))
(setf (gethash :notice ningle:*session*)"Updated")
`(,status-code:+see-other+
(:location ,(format nil "/user/~D" id)))))))))))
(defun post-user(request)
(format t "[INFO] You have reached post-user request")
(destructuring-bind
(&key
authenticity-token
id
number
name
full-name
sex
birthday-year
birthday-month
birthday-day
email
administrator
&allow-other-keys)
(with-connection (db)
(loop :for (key . value)
:in request
:collect (let((*package*(find-package :keyword)))
(read-from-string key))
:collect value)
(if (not (string= authenticity-token (token)))
`(403 () ("Denied"))
(let* ((id (ignore-errors (parse-integer id)))
(user (and id
(mito:find-dao 'rails-to-caveman.model::user :id id))))
(if (null user)
`(500 (:content-type "text/plain")
("Could not edit exists user."))
(progn (setf (rails-to-caveman.model::number-of user) number
(rails-to-caveman.model::name-of user) name
(rails-to-caveman.model::full-name-of user) full-name
(rails-to-caveman.model::sex-of user) sex
(rails-to-caveman.model::birthday-of user) "2021-12-21"
;; (format nil
;; "~A-~A-~A"
;; birthday-year
;; birthday-month
;; birthday-day)
(rails-to-caveman.model::email-of user) email
(rails-to-caveman.model::administrator-of user) administrator)
(multiple-value-bind (user errors)
(rails-to-caveman.model::validate-user user))
(if errors
`(400 ()(,(render "user/edit.html"
`(:user ,user
:errors ,errors
:token ,(token)))))
(progn (mito:save-dao user)
(setf (gethash :notice ningle:*session*)"Updated")
`(303 (:location
,(format nil "/user/~D" id))))))))))))
(defroute ("/entries" :method :post) (&key method)
(cond ((string= "put" method)
(create-entry (lack.request:request-body-parameters
ningle:*request*)))
(t `(401 () (,(format nil "Unknown method ~S" method))))))
(defroute entries-index "/entries" (&key id)
(with-connection (db)
(let ((author (when id (mito:find-dao
'rails-to-caveman.model::user :id id))))
(format t "[INFO] ~A" author)
(render "entries/index.html"
`(:member ,author
:user ,(current-user)
:news ,(articles-make 5)
:blogs ,(entries :limit 5)
:articles ,(articles-make 5)
:entries ,(entries :author author)
,@(roles)
:token ,(token)
;; :member ,(rails-to-caveman.model::author-of entry))))))
)))))
(defroute show-entry "/entries/:id" (&key id)
(if (null (ignore-errors (parse-integer id)))
(myway:next-route)
(with-connection (db)
(let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id id))
(entries (entries :limit 5)))
(render "entries/show.html"
`(,@(roles)
:entry ,entry
:token ,(token)
:user ,(current-user)
:entries ,entries
:blogs ,entries
:news ,(articles 5)
:member ,(rails-to-caveman.model::author-of entry)))))))
(defroute create-entry ("/entries" :method :post) ; :post was :put
(&key authenticity-token)
(step
(if (not (string= authenticity-token (token)))
'(401 () ("Denied"))
(with-connection (db)
(multiple-value-bind (entry errors)
(rails-to-caveman.model::validate-entry
(apply #'make-instance 'rails-to-caveman.model::entry
:user (current-user)
(request-params
(lack.request:request-body-parameters
ningle:*request*))))
(if errors (render "entries/new.html"
`(,@(roles)
:entry ,entry
:token ,(token)
:errors ,errors
:user ,(current-user)
:blogs ,(entries :limit 5)
:news ,(articles 5)))
(progn (mito:save-dao entry)
(setf (gethash :notice ningle:*session*)
"Stored")
`(303 (:location
,(format nil "/entries/~D"
(mito:object-id entry)))))))))))
(defroute ("/entries/:id" :method :post) (&key method id)
(step
(cond ((string= "post" method)
(update-entry (acons "ID" id
(lack.request:request-body-parameters
ningle:*request*))))
((string= "delete" method)
(destroy-entry (acons "ID" id
(lack.request:request-body-parameters
ningle:*request*))))
(t `(401 () (,(format nil "Unknown method ~S" method)))))))
(defun update-entry (request)
(destructuring-bind (&key
authenticity-token
id
title
body
posted-year
posted-month
posted-day
posted-hour
posted-min
&allow-other-keys)
(request-params request)
(if (not (string= authenticity-token(token)))
'(401 ()("Denied"))
(if (null (ignore-errors (parse-integer id)))
(myway:next-route)
(with-connection (db)
(let ((entry (mito:find-dao
'rails-to-caveman.model::entry :id id)))
(setf (rails-to-caveman.model::title-of entry) title
(rails-to-caveman.model::body-of entry) body
(rails-to-caveman.model::date-posted-of entry)
(format nil "~A-~A-~AT~A:~A:00"
posted-year
posted-month
posted-day
posted-hour
posted-min))
(multiple-value-bind (entry errors)
(rails-to-caveman.model::validate-entry entry)
(if errors (render "entries/edit.html"
`(,@(roles)
:member ,(rails-to-caveman.model::author-of entry)
:user ,(current-user)
:token ,(token)
:entry ,entry
:news ,(articles 5)
:blogs ,(entries :limit 5)
:errors ,errors ))
(progn (mito:save-dao entry)
(setf (gethash :notice ningle:*session*) "Updated")
`(303 (:location
,(format nil "/entries/~D"
(mito:object-id entry)))))))))))))
(defroute "/entries/new" (&key)
(step
(render "entries/new.html"
`(,@(roles)
:token ,(token)
:entry ,(make-instance 'rails-to-caveman.model::entry
:date-posted
(local-time:now))
:user ,(current-user)
:blogs ,(entries :limit 5)
:news ,(articles 5)))))
(defroute "/entries/:id/edit" (&key id)
(if (null (ignore-errors (parse-integer id)))
(myway:next-route)
(render "entries/edit.html"
`(,@(roles)
:entry ,(with-connection (db)
(mito:find-dao 'rails-to-caveman.model::entry :id id))
:user ,(current-user)
:blogs ,(entries :limit 5)
:news ,(articles 5)))))
(defroute destroy-entry ("/entries/:id" :method :delete)
(&key authenticity-token id)
(if (not (string= authenticity-token (token)))
'(401 () ("Denied"))
(with-connection (db)
(if (null (ignore-errors (parse-integer id)))
(myway:next-route)
(let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id id)))
(if (null entry)
`(401 () (,(format nil "Entry id ~A is not exist" id)))
(progn (mito:delete-dao entry)
(setf (gethash :notice ningle:*session*) "Deleted")
`(303 (:location
,(format nil "/user/~D/entries"
(mito:object-id (current-user))))))))))))
(defroute "/user/:id/entries" (&key id)
(entries-index (acons "ID" id
(lack.request:request-body-parameters
ningle:*request*))))
(defroute "/account" ()
(if (not (hermetic:logged-in-p))
'(401 ())
(render "users/show.html"
`(:user ,(current-user)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5) ,@(roles)
:token ,(token)))))
(defroute "/account/new"() )
(defroute "/account/edit" ()
(if (not (hermetic:logged-in-p))
'(401 ())
(render "accounts/edit.html"
`(:token ,(token)
:user ,(current-user)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5)
,@(roles)))))
;; Reimplemented in Chapter 13.
;; (defroute("/account" :method :post)
;; (&key number
;; name
;; full-name
;; sex
;; birthday-year
;; birthday-month
;; birthday-day
;; email
;; (administrator "1")
;; authenticity-token)
;; (if (not (string= authenticity-token (token)))
;; '(403 (:content-type "text/plain") ("Denied"))
;; (if (not (hermetic:logged-in-p))
;; '(401 ())
;; (let* ((user (current-user)))
;; (setf (rails-to-caveman.model::number-of user) number
;; (rails-to-caveman.model::name-of user) name
;; (rails-to-caveman.model::full-name-of user) full-name
;; (rails-to-caveman.model::sex-of user) sex
;; (rails-to-caveman.model::birthday-of user)
;; (format nil "~A~A~A" birthday-year
;; birthday-month
;; birthday-day)
;; (rails-to-caveman.model::email-of user) email
;; (rails-to-caveman.model::administrator-of user) administrator
;; (rails-to-caveman.model::password-of user)
;; (gethash :password ningle:*session*))
;; (multiple-value-bind (user errors)
;; (rails-to-caveman.model::validate-user user)
;; (if errors
;; `(400 ()
;; (,(render "accounts/edit.html"
;; `(:user ,user
;; :errors ,errors
;; :news (1 2 3 4 5)
;; :blogs (1 2 3 4 5)
;; ,@(roles)
;; :token ,(token)))))
;; (progn (with-connection (db)
;; (mito:save-dao user)
;; (setf (gethash :notice ningle:*session*)
;; "Updated")
;; '(303 (:location "/account"))))))))))
;; Reimplemented in Chapter 13.
#|
(defroute ("/account" :method :post)
(&rest args &key number name full-name sex email (administrator '("1"))
birthday-year birthday-month birthday-day authenticity-token image)
(declare (ignore number name full-name sex email administrator))
(with-authenticity-check ((:token (car authenticity-token)) :logged-in)
(let* ((user (current-user))
(image-file(rails-to-caveman.model::filename-of user)))
(multiple-value-bind (user errors)
(validation-validate (apply #'rails-to-caveman.model::update-instance
user
:password (gethash :password ningle:*session*)
:image image
(mapcar #'alexandria:ensure-car args)))
(if errors `(,status-code:+bad-request+ ()
(,(render "accounts/edit.html"
`(:user ,user
:errors ,errors
:news ,(articles 5)
:blogs ,(entries :limit 5)
,@(roles)
:token,(token)))))
(progn (unless (equal image-file
(ignore-errors(rails-to-caveman.model::filename-of user)))
(rails-to-caveman.model::purge user "account" image-file))
(mito:save-dao user)
(setf (gethash :notice ningle:*session*)"Updated")
`(,status-code:+see-other+ (:location "/account"))))))))
|#
;; Second Chapter 13 implementation
(defroute("/account" :method :post)
(&rest args &key number name full-name sex email
(administrator '("1")) birthday-year birthday-month
birthday-day authenticity-token image remove-profile-image-p)
(declare (ignore number name full-name sex email administrator
birthday-year birthday-month birthday-day))
(with-authenticity-check ((:token (car authenticity-token)) :logged-in)
(let* ((user (current-user))
(image-file(rails-to-caveman.model::filename-of user)))
(multiple-value-bind (user errors)
(validation-validate (apply #'rails-to-caveman.model::update-instance user
:password (gethash :password ningle:*session*)
:image image
(mapcar #'alexandria:ensure-car args)))
(if errors `(,status-code:+bad-request+ ()
(,(render "accounts/edit.html"
`(:user ,user
:errors ,errors
:news ,(articles 5)
:blogs ,(entries :limit 5)
,@(roles)
:token,(token)))))
(progn (trivia:match* ((car remove-profile-image-p)
(equal image-file
(ignore-errors
(rails-to-caveman.model::filename-of user))))
((_ nil) ; when specify new one, always remove old one.
(rails-to-caveman.model::purge user "account" image-file)
(storage::write (car image)
(mito:object-id user) "account"
(make-image-file image)))
((nil _)) ; do not remove, no new one, so do nothing.
((_ _) ; remove old, no new one.
(setf (rails-to-caveman.model::filename-of user) nil
(rails-to-caveman.model::content-type-of user) nil)
(rails-to-caveman.model::purge user "account" image-file)))
(mito:save-dao user)
(setf (gethash :notice ningle:*session*) "Updated")
`(,status-code:+see-other+ (:location "/account"))))))))
(defun purge (user subdirectory filename)
(let (deletedp (id (mito:object-id user)))
(dolist (pathname (uiop:directory-files
(storage::make-storage-pathname id subdirectory))
deletedp)
(let ((file (storage::read-from-base64-string (pathname-name pathname))))
(when (equal filename (storage::file-name file))
(setf deletedp t)
(storage::remove id subdirectory file))))))
(defroute("/account" :method :put)() )
(defroute("/account" :method :delete)() )
(defroute show-image "/entries/:id/images/:image-id" (&key id image-id)
(with-authenticity-check (:logged-in)
(if (null (mito:find-dao 'rails-to-caveman.model::entry :id id))
(myway:next-route)
(if (null (mito:find-dao 'rails-to-caveman.model::entry-image
:id image-id))
(myway:next-route)
`(,status-code:+see-other+
(:location ,(format nil "/entries/~A/images/~A/edit"
id image-id)))))))
(defroute add-image "/entries/:id/images/new" (&key id)
(with-authenticity-check (:logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id id)))
(render "entry-images/new.html"
`(,@(roles)
:entry ,entry
:user ,(current-user)
:token ,(token)
:news ,(articles 5)
:blogs ,(entries :limit 5))))))
(defroute ("/entries" :method :post) (&key method)
(method-case method ("put" (create-entry
(lack.request:request-body-parameters
ningle:*request*)))))
(defroute create-entry-image ("/entries/:entry-id/images" :method :put)
(&key authenticity-token entry-id image)
(with-authenticity-check ((:token (car authenticity-token)) :logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id entry-id)))
(multiple-value-bind (entry-image errors)
(validation-validate (make-instance
'rails-to-caveman.model::entry-image
:entry entry
:image image))
(let ((user (current-user)))
(if errors `(,status-code:+bad-request+()
(,(render
"entry-images/new.html"
`(,@(roles)
:errors ,errors
:entry ,entry
:user ,user
:token ,(token)
:news ,(articles 5)
:blogs ,(entries :limit 5)))))
(progn (storage::write (car image)
(mito:object-id user)
(format nil "entry~A"entry-id)
(make-image-file image))
(mito:insert-dao entry-image)
`(,status-code:+see-other+ (:location
,(format nil
"/entries/~A/images"
entry-id))))))))))
(defroute edit-entry-image "/entries/:entry-id/images/:image-id/edit"
(&key entry-id image-id)
(with-authenticity-check (:logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id entry-id))
(image (mito:find-dao 'rails-to-caveman.model::entry-image :id image-id)))
(render "entry-images/edit.html"
`(,@(roles)
:token ,(token)
:user ,(current-user)
:news ,(articles 5)
:entry ,entry
:image ,image
:blogs ,(entries :limit 5))))))
(defroute dispatch-entry-image ("/entries/:entry-id/images/:image-id"
:method :post)
(&key method entry-id image-id)
(method-case (alexandria:ensure-car method)
("post" (update-entry-image (acons "ENTRY-ID" entry-id
(acons "IMAGE-ID" image-id
(lack.request:request-body-parameters
ningle:*request*)))))
("delete" (destroy-entry-image (acons "ENTRY-ID" entry-id
(acons "IMAGE-ID" image-id
(lack.request:request-body-parameters
ningle:*request*)))))))
(defun update-entry-image (request)
(destructuring-bind (&key authenticity-token entry-id image-id image &allow-other-keys)
(request-params request)
(with-authenticity-check ((:token (car authenticity-token)) :logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id entry-id))
(entry-image (mito:find-dao
'rails-to-caveman.model::entry-image
:id image-id)))
(let ((old (rails-to-caveman.model::filename-of entry-image))
(user (current-user))
(subdirectory (format nil "entry~A"
(mito:object-id entry))))
(multiple-value-bind (entry-image errors)
(validation-validate
(rails-to-caveman.model::update-instance entry-image
:image image))
(if errors
`(,status-code:+bad-request+()
(,(render
"entry-images/edit.html"
`(,@(roles)
:user ,user
:news ,(articles 5)
:blogs ,(entries :limit 5)
:token ,(token)
:entry ,entry
:image ,entry-image
:errors ,errors))))
(progn (unless (equal old
(rails-to-caveman.model::filename-of entry-image))
(rails-to-caveman.model::purge user subdirectory old)
(storage::write (car image)
(mito:object-id user)
subdirectory (make-image-file image)))
(mito:save-dao entry-image)
`(,status-code:+see-other+ (:location
,(format nil
"/entries/~A/images"
(mito:object-id entry))))))))))))
(defroute destroy-entry-image ("/entries/:entry-id/images/:image-id"
:method :delete)
(&key authenticity-token entry-id image-id &allow-other-keys)
(with-authenticity-check ((:token authenticity-token) :logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id entry-id))
(entry-image (mito:find-dao 'rails-to-caveman.model::entry-image
:id image-id)))
(rails-to-caveman.model::purge (current-user) (format nil
"entry~A"
(mito:object-id entry))
(rails-to-caveman.model::filename-of entry-image))
(mito:delete-dao entry-image)
`(,status-code:+see-other+ (:location
,(format nil
"/entries/~A/images"
(mito:object-id entry)))))))
(defroute "/password" () ; as show
(if (not (hermetic:logged-in-p))
'(401 ())
'(303 (:location "/account"))))
(defroute "/password/edit" ()
(if (not (hermetic:logged-in-p))
'(401 ())
(render "passwords/edit.html"
`(:token ,(token)))))
(defroute ("/password" :method :post) (&key old new confirmation authenticity-token)
(if (not (hermetic:logged-in-p))
'(403 (:content-type "text/plain")("Denied"))
(let*((user(current-user))
(render-args `(:user ,user :token ,(token)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5))))
(if (not (string= authenticity-token(token)))
`(403 (:content-type "text/plain") ("Denied"))
(if (equal "" old)
(render "password/edit.html"
(list* :errors '((current-password . "is required"))
render-args))
(if (not
(cl-pass:check-password old (rails-to-caveman.model::password-of user)))
(render "passwords/edit.html"
(list* :errors '((password . "is not correct")) render-args))
(if (not (equal new confirmation))
(render "passwords/edit.html"
(list* :errors '((confirmation . "is failed"))
render-args))
(progn (setf (rails-to-caveman.model::password-of user) new)
(multiple-value-bind (user errors)
(rails-to-caveman.model::validate-user user
'rails-to-caveman.model::password)
(if errors
(render "passwords/edit.html"
(list* :errors errors render-args))
(progn (mito:save-dao user)
(setf (gethash :notice ningle:*session*) "Password is changed")
'(303 (:location "/account")))))))))))))
(defroute ("/session" :method :post) (&key method)
(cond ((string= "delete" method)
(logout (lack.request:request-body-parameters ningle:*request*)))
((string= "post" method)
(post-session (lack.request:request-body-parameters ningle:*request*)))
(t `(400 (:content-type "text/plain")
(,(format nil "Unknown method ~S" method))))))
(defun post-session (request)
(destructuring-bind
(&key name password authenticity-token &allow-other-keys)
(request-params request)
(if (not (string= authenticity-token (token)))
`(403 (:content-type "text/plain") ("Denied"))
(let ((params (list :|username| name
:|password| password)))
(format t "You look like you have logged in")
(hermetic:login params
(progn (with-connection (db)
(setf
(gethash :id ningle:*session*) (mito:object-id
(mito:find-dao
'rails-to-caveman.model::user
:name name))
(gethash :password ningle:*session*) password))
'(303 (:location "/")))
(progn (setf (gethash :alert ningle:*session*) "Name and password don't match.")
'(303 (:location "/")))
(progn (setf (gethash :alert ningle:*session*) "No such user")
'(303 (:location "/"))))))))
(defroute logout ("/session" :method :delete) (&key authenticity-token)
(if (not (string= authenticity-token (token)))
`(403 (:content-type "text/plain") ("Denied"))
(hermetic::logout (progn (flash-gethash :id ningle:*session*)
'(303 (:location "/")))
'(303 (:location "/")))))
(defroute "/articles" ()
(render "articles/index.html"
`(:user ,(current-user)
:news ,(articles-make 5)
:blogs (1 2 3 4 5)
:token ,(token)
:articles
,(hermetic:auth (:adminstrator)
(with-connection (db)
(mito:retrieve-dao 'rails-to-caveman.model::article))
(articles-make 5))
,@(roles))))
(defroute ("/articles" :method :post) (&key method)
(cond ((string= "put" method) (new-article
(lack.request:request-body-parameters ningle:*request*)))
(t `(401 () (,(format nil "Unknown method ~S" method))))))
(defroute "/articles/:id" (&key id)
;; (if (null (ignore-errors (parse-integer id)))
;; myway.mapper:next-route)
;; (let ((article (with-connection (db)
;; (mito:find-dao 'rails-to-caveman.model::article
;; :id id)))
;; (if (find :administrator (hermetic:roles))
;; #0=(render "articles/show.html"
;; `(:articles (1 2 3 4 5) ;,article
;; ,@(roles)
;; :token ,(token)
;; :user ,(current-user)
;; ;; :news ,(articles-make 5)
;; :news (1 2 3 4 5)
;; :blogs (1 2 3 4 5))
;; (if (publicp article)
;; #0# '(404 ()
;; ("No articles"))))))))
(render "articles/show.html"
`(:article ,(with-connection (db)
(mito:find-dao 'rails-to-caveman.model::article :id id))
,@(roles)
:user ,(current-user)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5))))
(defroute ("/articles/:id" :method :post)(&key method id)
(cond ((and (string= "post" method)
(ignore-errors(parse-integer id)))
(edit-article (acons "ID" id
(lack.request:request-body-parameters ningle:*request*))))
((and (string= "delete" method)
(ignore-errors(parse-integer id)))
(destroy-article (acons "ID" id
(lack.request:request-body-parameters ningle:*request*))))
(t `(401()(,(format nil "Unknown method ~S"method))))))
(defroute destroy-article ("/article/:id" :method :delete)
(&key authenticity-token id)
(step
(if (not (string= authenticity-token(token)))
'(401()("Denied"))
(if (not (hermetic:logged-in-p))
'(403 () ("Denied"))
(if (null (ignore-errors (setf id (parse-integer id))))
(myway.mapper:next-route)
(progn (with-connection (db)
(mito:delete-by-values 'rails-to-caveman.model::article :id id))
`(303 (:location "/articles"))))))))
(defroute "/articles/new" ()
(render "articles/new.html"
`(:article ,(make-instance 'rails-to-caveman.model::article)
:user ,(current-user)
:new (1 2 3 4 5)
:blogs (1 2 3 4 5)
,@(roles)
:token ,(token))))
(defroute new-article ("/articles" :method :put) ; :put need to be put?
(&key authenticity-token no-expiration-p)
(if (not (string= authenticity-token (token)))
'(401 () ("Denied"))
(let ((render-args `(:user
,(current-user)
,@(roles)
:token ,(token)
:news ,(articles 5)
:blogs (1 2 3 4 5))))
(multiple-value-bind (article errors)
(rails-to-caveman.model::validate-article
(apply #'make-instance 'rails-to-caveman.model::article
(request-params (lack.request:request-body-parameters
ningle:*request*))))
(if errors
(render "articles/new.html"
(list* :article article
:errors errors
:no-expiration-p no-expiration-p
render-args))
(progn (with-connection (db)
(mito:insert-dao article)
(setf (gethash :notice ningle:*session*)"Stored")
`(303 (:location
,(format nil "/articles/~D"
(mito:object-id article)))))))))))
(defroute new-article ("/articles" :method :put)
(&key authenticity-token
released-year
released-month
released-day
released-hour
released-min
expired-year
expired-month
expired-day
expired-hour
expired-min)
;; (dev:peep ningle:*request*)
(force-output)
(if (not (string= authenticity-token (token)))
`(401 () ("Denied"))
(with-connection (db)
(let ((render-args `(:user ,(current-user)
,@(roles)
:token ,(token)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5)))
(now-time (local-time:now)))
(multiple-value-bind (article errors)
(rails-to-caveman.model::validate-article
(apply #'make-instance 'rails-to-caveman.model::article
:allow-other-keys t
;; This deviates from Chapter 9's code because
;; the new article form does not populate the
;; date-released part of the form properly. So,
;; to get around it, date-released is created
;; here instead of it being passed in to this
;; function as values to be parsed.
:date-released (format nil "~A-~A-~AT~A:~A:00"
(local-time:timestamp-year now-time)
(local-time:timestamp-month now-time)
(local-time:timestamp-day now-time)
(local-time:timestamp-hour now-time)
(local-time:timestamp-minute now-time))
:date-expired (format nil "~A-~A-~AT~A:~A:00"
expired-year
expired-month
expired-day
expired-hour
expired-min)
(request-params (lack.request:request-body-parameters ningle:*request*))))
(if errors
(step
(render "articles/new.html"
(list* :article article
:errors errors
render-args)))
(progn (mito:insert-dao article)
(setf (gethash :notice ningle:*session*) "Stored")
`(303 (:location
,(format nil "/articles/~D"
(mito:object-id article)))))))))))
(defroute "/articles/:id/edit" (&key id)
(step
(render "articles/edit.html"
`(:article ,(with-connection (db)
(mito:find-dao
'rails-to-caveman.model::article :id id))
:user ,(current-user)
,@(roles)
:token ,(token)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5)))))
(defun edit-article (request)
(step
(destructuring-bind
(&key authenticity-token
id
title
body
released-min
released-hour
released-day
released-month
released-year
expired-min
expired-hour
expired-day
expired-month
expired-year
member-only
&allow-other-keys)
(request-params request)
(if (not (string= authenticity-token (token)))
'(401 () ("Denied"))
(if (not (hermetic:logged-in-p))
'(403 () ("Denied"))
(let ((article (with-connection (db)
(mito:find-dao
'rails-to-caveman.model::article :id id))))
;; (format t "[INFO] ~A" (getf article 'title))
(setf (rails-to-caveman.model::title-of article) title
(rails-to-caveman.model::body-of article) body
(rails-to-caveman.model::date-released-of article)
(format nil "~A-~A-~AT~A:~A:00"
released-year
released-month
released-day
released-hour
released-min)
(rails-to-caveman.model::date-expired-of article)
(format nil "~A-~A-~AT~A:~A:00"
expired-year
expired-month
expired-day
expired-hour
expired-min)
(rails-to-caveman.model::member-only article) member-only)
(multiple-value-bind (article errors)
(rails-to-caveman.model::validate-article article)
(if errors (render "articles/edit.html"
`(:article ,article
:errors ,errors
:user ,(current-user)
,@(roles)
:token ,(token)
:news (1 2 3 4 5)
:blogs (1 2 3 4 5)))
(progn (with-connection (db)
(mito:save-dao article))
(setf (gethash :notice ningle:*session*) "Updated")
`(303 (:location ,(format nil "/articles/~D"
(mito:object-id article)))))))))))))
(defroute "/storage/:id/:subdirectory/:filename" (&key id
subdirectory
filename
size
content-type)
(let* ((original-file (storage::make-file :name filename
:content-type content-type))
(to-load original-file))
(when size (let ((converted-file (storage::make-file :name filename
:size size
:content-type content-type)))
(unless (storage::probe-file id subdirectory converted-file)
(storage::convert id subdirectory original-file converted-file))
(setf to-load converted-file)))
(multiple-value-bind (content length)
(storage::read id subdirectory to-load)
`(,status-code:+ok+ (:content-type ,content-type
:content-length ,length) ,content))))
(defroute index-entry-image "/entries/:id/images" (&key id)
(with-authenticity-check (:logged-in)
(ensure-let ((entry (mito:find-dao 'rails-to-caveman.model::entry :id id)))
(let ((images (mito:retrieve-dao
'rails-to-caveman.model::entry-image
:entry-id (mito:object-id entry))))
(render "entry-images/index.html"
`(,@(roles)
:images ,(loop :for image :in images
:for i :upfrom 1
:collect (cons image i))
:entry ,entry
:user ,(current-user)
:token ,(token)
:news ,(articles-make 5)
:articles ,(articles-make 5)
:blogs ,(entries :limit 5) ))))))
(defroute "/about" ()
;; about.html should be in the /templates directory.
(render #P"about.html" '(:page-title "About")))
(defroute "/hello/:name" (&key name)
;; Substitutes ':name' with `NAME'.
(format nil "Hello, ~A" name))
(defroute "/say/*/to/*" (&key splat)
;; If route is /say/hello/to/world (in the browser). It will match
;; to /say/hello/to/world. 'hello' and 'world' are the wildcard
;; values in this example.
(format nil "~A" splat))
(defroute ("/hello/([\\w]+)" :regexp t) (&key captures)
;; Parse the second part of the URL via a regular expression
;; (regexp). The result of the parsed regexp text is stored in
;; `CAPTURES', hence the use of 'first' in the format string.
(format nil "Hello, ~A!" (first captures)))
(defroute "/hello/?:name?" (&key name)
;; Generates two types of routes:
;; 1. /hello/earth
;; 2. /hello?NAME=earth
;; The query string must be in UPPERCASE. Otherwise, the `NAME' will
;; be bound to `nil'.
(format nil "Hello, ~A" name))
(defroute "/hello/?:name?" (&key |name|)
;; If you want the query string in lowercase, enclose `name' (in
;; this case) with vertical bars '|'. This will force you to have
;; only one route (unlike the route above). `NAME' will now bind to
;; `NIL'.
;; 1. /hello?name=earth
;; 2. /hello?NAME=earth <--- no longer works ('earth' binds to nil).
;; 3. /hello/earth <--- no longer works
(format nil "Hello, ~A" |name|))
(defroute "/lesson/step*/:name" (&key splat name)
;; Directory style: Working with Parameters.
;; Example URL: /lesson/step1/Sato
(case (parse-integer (car splat) :junk-allowed t)
(1 (format nil "Hello, ~A" name))))
(defroute "/lesson/step*" (&key splat (|name| "Anonymous"))
;; 'Anonymous' is the default value for `|name|'.
;; Query style: Working with Parameters.
;; Example URL: /lesson/step1?name=Sato
(case (parse-integer (car splat) :junk-allowed t)
(1 (format nil "Hello, ~A" |name|))))
(defroute "/lesson/step*" (&key splat name)
;; If /lesson/step1 is used, it will be redirected to /lesson/step2,
;; then /lesson/step3 and finally /lesson/step4. No matter where you
;; start (along as it is below 4), the redirects will always take
;; you to /lesson/step4.
;; The example includes `NAME' BUT it is never used. I am keeping it
;; here for consistency between the reference material and this code
;; base.
(case (parse-integer (car splat) :junk-allowed t)
(1 '(302 (:location "/lesson/step2")))
(2 '(302 (:location "/lesson/step3")))
(3 '(302 (:location "/lesson/step4")))
(4 "Moved to step4")
;; To be honest, I do not know what this is actually doing. It is
;; mentioned in 'STEP5 Flash' in Chapter 3 (I.E. Tutorial 3:
;; Routing). This applies to case's 5 and 6.
(5 (setf (gethash :notice *session*) "Move to step6")
`(302 (:location "/lesson/step6")))
(6 (let((notice (gethash :notice *session*)))
(remhash :notice *session*) notice))
;; This is part of an example about using djula (which is a
;; template engine used by Caveman2. djula is a port of Python's
;; Django template engine.
;; step7.html should be in the /templates directory.
(7 (render "step7.html"
`(:price ,(floor(* 2000 1.08)))))
(8 (render "step7.html" '(:price 1000)))
(9 (render "step9.html"
'(:comment "<script>alert('danger')</script>Hello")))
;; If you dare to embed HTML, add safe after the variable
;; reference on the View side (step10.html).
(10 (render "step10.html"
'(:comment "<strong>safe html</strong>")))
(11 `(200 (:content-type "text/html; charset=utf-8")
(, (let ((population 704414) (surface 141.31))
(render "step11.html"
`(:contents
,(format nil
;; ~D = Decimal
;; ~,,2F = Fixed-Format
;; Floating-Point
;; ~,,2F = Print exactly two
;; digits after the decimal
;; point and many as necessary
;; before the decimal point.
"Population: ~D Floor Surface: ~D Population/Surface: ~,,2F"
population
(floor surface)
(/ population surface))))))))
(12 (render "step11.html"
`(:contents ,(local-time:format-timestring
nil
(local-time:now)
:format '((:year 4)"/"(:month 2)"/"(:day 2)"(" :short-weekday ") "
(:hour 2)":"(:min 2)":"(:sec 2))))))
(13 `(200 (:content-type "text/html; charset=utf-8")
;; This view uses 'format' in step13.html (view in
;; /templates directory).
(,(render "step13.html" '(:population 127767944)))))
(14 (render "step14.html"
;; The view uses a custom filter which was added to
;; view.lisp.
`(:contents ,(format nil "foo~%bar~%bazz"))))
;; The view demonstrates how to form links.
(15 (render "step15.html"))
;; The view demonstrates how to display images.
;; Images are stored in the /static/images directory.
(16 (render "step16.html"))
;; Provides control branches which you can navigate via djula in
;; step17.html (/templates directory).
(17 `(200 (:content-type "text/html; charset=utf-8")
;; Adjust `STOCK' to adjust what is viewed in step17.html.
(,(let((stock 10))
(render "step17.html"
`(:stock-zerop ,(< 0 stock) :stock ,stock))))))
;; This creates a list (cons list) which is then cycled through in
;; /templates/step18.html using the djula template engine..
(18 (render "step18.html"
'(:items
((:pan . 2680)
(:glass . 2550)
(:pepper-mill . 4515)
(:peeler . 945)))))))
(defun token ()
"CSRF token."
(cdr (assoc "lack.session"
(lack.request:request-cookies ningle:*request*)
:test #'string=) ;string equality (always forget this)
))
(defun flash-gethash (key table)
(let ((value (gethash key table)))
(remhash key table)
value))
;;
;; Error pages
(defmethod on-exception ((app <web>) (code (eql 404)))
(declare (ignore app))
(merge-pathnames #P"_errors/404.html"
*template-directory*))
(hermetic:setup :user-p (lambda (name)
(with-connection (db)
(mito:find-dao
'rails-to-caveman.model::user :name name)))
:user-pass (lambda (name)
(rails-to-caveman.model::password-of
(with-connection (db)
(mito:find-dao 'rails-to-caveman.model::user :name name))))
:user-roles (lambda (name)
(cons :logged-in
(let ((user (with-connection (db)
(mito:find-dao 'rails-to-caveman.model::user :name name))))
(and user (rails-to-caveman.model::administrator-of user)
'(:administrator)))))
:session ningle:*session*
:denied (constantly '(400 (:content-type "text/plain") ("Authenticate denied"))))
(defun request-params (request)
(loop :for (key . value) :in request
:collect (let ((*package* (find-package :keyword)))
(read-from-string key))
:collect value))
(defun roles()
(loop :for role :in (hermetic:roles)
:collect role
:collect t))
(defun current-user ()
(with-connection (db)
(mito:find-dao
'rails-to-caveman.model::user
:id (gethash :id ningle:*session*))))
(defun publicp (article)
(local-time:timestamp< (date-released-of article)
(local-time:now)
(date-expired-of article)))
(defun format-to-date (&optional(time (local-time:now)))
(local-time:format-timestring
nil
time
:format '((:year 4)"-"(:month 2)"-"(:day 2))))
(defun articles-make (n &key (logged-in-p (hermetic:logged-in-p))
(user(and logged-in-p (current-user))))
(if logged-in-p
(if (rails-to-caveman.model::administrator-of user)
(with-connection (db)
(mito:select-dao 'rails-to-caveman.model::article
(sxql:order-by (:desc :date-released))
(sxql:limit n))
(let ((now (rails-to-caveman.web::format-to-date)))
(mito:select-dao 'rails-to-caveman.model::article
(sxql:where (:and (:< :date-released now)))
;; (:< now :date-expired)))
(sxql:order-by (:desc :date-released))
(sxql:limit n)))))
(let ((now (rails-to-caveman.web::format-to-date)))
(with-connection (db)
(mito:select-dao 'rails-to-caveman.model::article
(sxql:where (:and (:< :date-released now)
(:< now :date-expired)
(:= :only-member rails-to-caveman.model::+false+)))
(sxql:order-by (:desc :date-released))
(sxql:limit n))))))
;; (defun articles (n &key (logged-in-p(hermetic:logged-in-p))
;; (user (and logged-in-p (current-user))))
;; (if logged-in-p
;; (if (your-app.model::administrator-of user)
;; (mito:select-dao 'your-app.model::article
;; (sxql:order-by (:desc :date-released))
;; (sxql:limit n))
;; (let ((now(your-app.web::format-to-date)))
;; (mito:select-dao 'your-app.model::article
;; (sxql:where
;; (:and (:< :date-released now)
;; (:< now :date-expired)))
;; (sxql:order-by (:desc :date-released))
;; (sxql:limit n))))
;; (let ((now(your-app.web::format-to-date)))
;; (mito:select-dao 'your-app.model::article
;; (sxql:where (:and (:< :date-released now)
;; (:< now :date-expired)
;; (:= :only-member your-app.model::+false+)))
;; (sxql:order-by(:desc :date-released))
;; (sxql:limit n)))))
(defun entries (&key (logged-in-p (hermetic:logged-in-p))
(user (and logged-in-p (current-user)))
author limit)
(with-connection (db)
(mito:select-dao 'rails-to-caveman.model::entry
(sxql:where (trivia:match*(logged-in-p author)
((nil nil) `(:= "public" :status))
((nil _)
`(:and (:= ,(mito:object-id author) :user-id)
(:= "public" :status)))
((_ nil) `(:or (:= "public" :status)
(:= "member-only" :status)
(:and (:= "draft" :stats)
(:= ,(mito:object-id user)
:user-id))))
((_ _) (if(mito:object= user author)
`(:= ,(mito:object-id user)
:user-id)
`(:and (:= ,(mito:object-id author) :user-id)
(:or (:= "public" :status)
(:= "member-only" :status)))))))
(sxql:order-by (:desc :date-posted)) (when limit (sxql:limit limit)))))
;;; -------------------------------------------------------------------------
;;; Custom Error Pages
;;; 'throw-code' seems to be the most convenient way to generate an
;;; error page. But, it does not lend itself to generating a more
;;; involved error page like the 'on-exception' defmethod's do.
;;; (throw-code 405 :allow "put get" :method "post"))
(defroute "/error-test" ()
;; Change the error code (I.E. 405) to test different errors.
(throw-code 405 :allow "put get" :method "post"))
(defmethod on-exception ((app <web>) (code method-not-allowed))
(setf (getf (lack.response:response-headers ningle:*response*):allow)
(allow code))
(format nil "Unknown method ~S" (not-allowed code)))
(defmethod on-exception ((app <web>) (code method-not-allowed))
`(,(caveman2.exception:exception-code code)
(:allow ,(allow code))
(,(format nil "Unknown method ~S" (not-allowed code)))))
;;; The original 'on-exception' 404 error is higher up this file.
(defmethod on-exception ((app <web>) (code (eql 404)))
(declare (ignore app))
(render "_errors/not-found.html")) ; You can adjust the '404 page'.
;;; Here is a commented-out copy of it for quick reference.
;; (defmethod on-exception ((app <web>) (code (eql 404)))
;; (declare (ignore app))
;; (merge-pathnames #P"_errors/404.html"
;; *template-directory*))
#| I DO NOT KNOW WHAT 'STATUS-CODE:+BAD-REQUEST+' IS REFERRING TO
======================================================================
This method is taken directly from Chapter 11. The 'status-code' part
is not recognised which means I cannot compile the program (or use
quickload). Because of this I have commented it out so I can keep it
as a reference and hopefully work out where '+bad-request+' resides so
I can import it and get this piece of code working.
(defmethod on-exception ((app <web>)
(code (eql status-code:+bad-request+)))
(declare (ignore app))
(render "errors/bad-request.html"
`(:alert ,(flash-gethash :alert ningle:*session*))))
|#
#| Added in Chapter 11 (Errors)
======================================================================
Below, I think, is examples of how to form more complicated error
messages/pages/exceptions beyond what is provided by Caveman. I cannot
say for certain because the chapter's text is a bit hard to
read (Chapter 11). Google's Japanese to English translation is the
worse of all the chapters I have read up to now.
|#
(define-condition method-not-allowed (caveman2.exception:http-exception)
((allow
:initarg :allow
:reader allow)
(method
:initarg :method
:reader not-allowed)))
;;; --------------------------------------------------------------------
;;; Code examples for using 'define-condition' above.
;;; These code snippets are taken directly from Chapter 11.
#|
(let ((caveman2.exception:*exception-class*
'method-not-allowed))
(throw-code 405 :allow "put get" :method "post"))
(error 'method-not-allowed :method "post" :allow "put get" :code 405)
`(405 (:allow "put get")(,(format nil "Unknown method ~S""post")))
|#
#| Contains the code in Chapter 12.5.
======================================================================
At the time of writing, I do not know where/if the code in this
chapter is supposed to go into the main source code files of the
project. Until then, I have put the code here as a future reference
and as a place to store it until I have worked it out.
|#
(defvar *doc* (plump:parse
(dexador:get "https://www.w3.org/protocols/rfc2616/rfc2616-sec10.html")))
(defun constant-forms()
(mapcon (lambda(list)
(when (equal "h3" (plump:tag-name (car list)))
(let*((position (position "h3"
(cdr list)
:test #'equal
:key #'plump:tag-name))
(ps (subseq (cdr list) 0 position))
(h3 (loop :for element
:across (plump:children (car list))
:when (plump:text-node-p element)
:collect (plump:text element)
:into result
:finally (return
(string-trim " "
(apply #'concatenate 'string result)))))
(code))
(multiple-value-bind (match-p start)
(ppcre:scan "^[0-9][0-9][0-9]" h3)
(if (and match-p (not (eql 306
(setf code (parse-integer h3
:junk-allowed t)))))
`((defconstant ,(read-from-string (format nil "+~A+"
(substitute #\- #\space(string-trim
" "
(ppcre::nsubseq h3 start)))))
,code ,(string-trim '(#\newline #\space)
(remove #\return
(apply #'concatenate 'string
(mapcar #'plump:text ps)))))))))))
(let* ((vector (plump:child-elements (aref (clss:select "body" *doc*)0)))
(position (position "h3" vector :test #'equal
:key #'plump:tag-name)))
(coerce (subseq vector position)'list))))
#| Run the following in the REPL
(constant-forms) ; <------ enter this
It should give you an output similar to this...
((DEFCONSTANT +CONTINUE+ 100
"The client SHOULD continue with its request. This interim response
is used to inform the client that the initial part of the request
has been received and has not yet been rejected by the server. The
client SHOULD continue by sending the remainder of the request or,
if the request has already been completed, ignore this
response. The server MUST send a final response after the request
has been completed. See section 8.2.3 for detailed discussion of
the use and handling of this status code."))
|#
(defun thunk() (let ((list (constant-forms)))
(format t "~&~(~S~)"
`(in-package :cl-user))
(format t "~&~(~S~)"
`(defpackage #:rfc2616-sec10 (:use :cl)
(:nicknames #:status-code)
(:export ,@(mapcar #'cadr list))))
(format t "~&~(~S~)" `(in-package #:rfc2616-sec10))
(format t "~{~&~%~S~}" list)))
(defmacro with-authenticity-check ((&rest check*) &body body)
(labels ((rec (list)
(if(endp list)
`(progn ,@body)
(body (caar list)
(cadar list)
(cdr list))))
(body (key value rest)
(ecase key (:token
`(if (not (string= ,value (token)))
(throw-code status-code:+forbidden+)
,(rec rest)))
(:logged-in `(if (not(hermetic:logged-in-p))
(throw-code status-code:+unauthorized+)
,(rec rest))))))
(rec (mapcar #'alexandria:ensure-list check*))))
(defmacro ensure-let ((&rest bind*) &body body)
(labels ((rec(binds)
(if (endp binds)
`(progn ,@body)
(body (car binds)(cdr binds))))
(body (bind rest)
`(let (,bind)
(if (null ,(car bind))
(myway:next-route) ,(rec rest))))) (rec bind*)))
(defgeneric update-instance (object &rest args))
(defmethod update-instance ((object standard-object )&rest args)
(loop :with initargs = (loop :for key :in args :by #'cddr :collect key)
:for slot :in (c2mop:class-slots (class-of object))
:for keys = (intersection (c2mop:slot-definition-initargs slot) initargs)
:when (and keys (or (null (cdr keys)) (error "Dupcated initargs ~S"keys)))
:do (let ((value (getf args(car keys))))
(unless (equal "" value)
(setf (slot-value object
(c2mop:slot-definition-name slot))
value))))
object)
(define-method-combination validate()
((primary (validate) :required t))
(labels((rec(methods)
(if (endp (cdr methods))
`(call-method ,(car methods) nil)
`(multiple-value-bind(o e),(rec (cdr methods))
(values o (append e (nth-value 1 (call-method ,(car methods) nil))))))))
(rec primary)))
(defgeneric validate(object &key target-slots test)
(:method-combination validate))
(defmacro method-case (method &rest clauses)
(let ((var (gensym"VAR")))
`(let ((,var ,method))
(cond ,@(mapcar (lambda(clause)
`((string= ,(car clause),var),@(cdr clause)))
clauses)
(t (throw-code status-code:+method-not-allowed+))))))
;;; Added in Chapter 13
;; (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)
;; (with-check-validate (object
;; :target-slots target-slots
;; :test test)
;; ((entry (:require t)) (filename (:require t)))))