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.
1248 lines
40 KiB
1248 lines
40 KiB
;; (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 |
|
#:cl-who) |
|
(: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"))))))))) |
|
|
|
(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)))))) |
|
|
|
;;; YOU ARE UP TO HERE: |
|
;;; CAN'T GET THE VALIDATION TO WORK WHEN CREATING A NEW ACCOUNT. |
|
(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))))) |
|
|
|
(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")))))))))) |
|
|
|
(defroute("/account" :method :put)() ) |
|
(defroute("/account" :method :delete)() ) |
|
|
|
(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 "/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"))) |
|
|#
|
|
|