Browse Source

end of session commit -- middle of Chapter 13.

master
Craig Oates 2 years ago
parent
commit
96b28bc915
  1. BIN
      profile.png
  2. 10
      rails-to-caveman.asd
  3. 132
      src/ch12.5.lisp
  4. 119
      src/helpers.lisp
  5. 228
      src/model.lisp
  6. 604
      src/rfc2616-sec10.lisp
  7. 73
      src/storage.lisp
  8. 596
      src/web.lisp
  9. 3
      templates/accounts/edit.html
  10. 3
      templates/entries/footer.html
  11. 29
      templates/entries/show.html
  12. 15
      templates/entry-images/edit.html
  13. 11
      templates/entry-images/form.html
  14. 50
      templates/entry-images/index.html
  15. 16
      templates/entry-images/new.html
  16. 20
      templates/shared/user_form.html
  17. 96
      templates/users/body.html
  18. 2
      templates/users/edit.html
  19. 3
      templates/users/new.html

BIN
profile.png

Binary file not shown.

After

Width:  |  Height:  |  Size: 14 KiB

10
rails-to-caveman.asd

@ -12,6 +12,9 @@
#:local-time ; <-- Added Chapter 6
#:ratify ; <-- Chapter 7
#:trivia ; <-- Chapter 10
#:plump ; <-- Chapter 12.5
#:dexador ;<-- Chapter 12.5
#:clss
;; for @route annotation
#:cl-syntax-annot
@ -32,11 +35,14 @@
:components
((:module "src"
:components ((:file "main" :depends-on ("config" "view" "db"))
(:file "web" :depends-on ("view" "model"))
(:file "web" :depends-on ("view" "model" "rfc2616-sec10"))
(:file "view" :depends-on ("locale" "config"))
(:file "db" :depends-on ("config"))
(:file "model" :depends-on ("db"))
(:file "model" :depends-on ("db" "storage"))
(:file "locale" :depends-on ("config")) ; <--- This!
(:file "storage") ; Chapter 13
(:file "rfc2616-sec10") ; Chapter 12.5 (status-code)
;; (:file "helpers" :depends-on ("rfc2616-sec10")) ; Chapter 12.5
(:file "config"))))
:description "Rails to Caveman2 port."
:in-order-to ((test-op (test-op "rails-to-caveman-test"))))

132
src/ch12.5.lisp

@ -0,0 +1,132 @@
#| 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+))))))

119
src/helpers.lisp

@ -0,0 +1,119 @@
(defpackage #:rails-to-caveman.helpers
(:use #:cl
#:plump
;; #:dexador
#:clss
#:status-code)
(:shadowing-import-from #:dexador
#:get)
(:export #:*doc*))
(in-package #:rails-to-caveman.helpers)
(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))))
(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+))))))

228
src/model.lisp

@ -46,9 +46,28 @@
(defun user-article-and-entry-table-check ()
(with-connection (db)
(mito:ensure-table-exists '(user article entry))))
(defclass user ()
(defclass file()
((filename :col-type (or :null (:varchar 128))
:initarg :filename
:accessor filename-of)
(content-type :col-type (or :null (:varchar 32))
:initarg :content-type
:accessor content-type-of))
#| USE OF MITO:DAO-TABLE-MIXIN (Chapter 13)
===================================================================
Use 'table-mixin' to pull together data (I.E. database fields) from
different tables. Database tables can be inherited in mito so you do
no need a table for every structure you want to create/map between the
source code and the database layer.
|#
(:metaclass mito:dao-table-mixin))
(defclass image (file)()
;; See note about dao-table-mixin above in 'file' class.
(:metaclass mito:dao-table-mixin))
(defclass user (image) ; 'image' class defined below (chapter 13).
((number :col-type :integer
:initarg :number
:accessor number-of)
@ -80,67 +99,6 @@
(:metaclass mito:dao-table-class))
(defun seeds()
;; '#(' are ARRAY LITERALS. I keep forgetting this and need to look
;; it up.
(let ((names
#("Taro" "Jiro" "Hana" "John" "Mike" "Sophy" "Bill" "Alex" "Mary" "Tom"))
(fnames ; First Names
#("Hippo" "Darling" "Lopez" "Jerry"))
(gnames ; Given Names
#("Orange" "Fox" "Snake")))
(with-connection (db)
(dotimes (x 10)
(mito:create-dao 'user
:number (+ x 10)
:name (aref names x)
:full-name (format nil "~A ~A"
(aref fnames (rem x 4))
(aref gnames (rem x 3)))
:email (format nil "~A@example.com" (aref names x))
:birthday "1981-12-01"
:sex (nth (rem x 3) '(1 1 2))
;; Removed 'p' from end of :administrator --
;; so the code differs from the code in the
;; tutorial (Chapter 4). I had to change it
;; because it produced errors when trying to
;; seed the database (using 'seeds'
;; function. I have, also, left a note in the
;; 'user' class definition highlighting this.
:administrator (zerop 0)
:password "asagao!"))
;; "#.(" is an ARRAY LITERAL. (Noted in 'Loving Common Lisp' book).
(let ((body #.(with-output-to-string (*standard-output*)
(format t "Morning glory wins.~2%")
(write-line "hgoe hoge boge hoge")
(write-line "fuga fuga guffaug uga")
(write-line "tasdf asdf asdf sadf")))
(now-time (local-time:now)))
(dotimes (x 10)
(mito:create-dao 'article
:title (format nil "Result:~D" x)
:body body
:date-released (local-time:timestamp- now-time (- 8 x) :day)
:date-expired (local-time:timestamp- now-time (- 2 x) :day)
:member-only (zerop 0)))
(dolist (name '("Jiro" "Taro" "Hana"))
(let ((user (mito:find-dao 'user :name name)))
(when user (dotimes (x 10)
(mito:create-dao 'entry
:user user
:title (format nil "Title~D" x)
:body body
:date-posted (local-time:timestamp- now-time (- 10 x) :day)
:status (nth (rem x 3) '("draft" "member-only" "public")))))))))))
(defun rebuild ()
"Drops the current database table, recreates it and populates it using seeded data."
(with-connection (db)
(mapc #'mito:ensure-table-exists '(user article entry))
(mapc #'mito:recreate-table '(user article entry)))
(seeds))
(defun ids ()
"Produces a list of all the Id's in the database. Part of Chapter 4
tutorial and is a port of the 'ids method' in the Ruby on Rails book
@ -488,6 +446,18 @@ reference for future projects. This is a learning project after all.
posted-hour
posted-min))) ,@args)))
(defclass entry-image (image)
((entry
:col-type entry
:initarg :entry
:accerror entry-of)
(alt-text
:col-type (:varchar 128)
:initform "alt-text"
:initarg :alt-text
:accerror alt-text-of))
(:metaclass mito:dao-table-class))
(defmethod mito:delete-dao :before((user user))
(mito:delete-by-values 'entry
:user-id (mito:object-id user)))
@ -502,3 +472,135 @@ reference for future projects. This is a learning project after all.
(:key #'local-time:parse-timestring))
(status (:require t)
(:assert (find status '("draft" "member-only" "public"):test #'equal))))))
;;; Added in Chapter 13
;; (defmethod validation:validate validation:validate ((image image) &key target-slots test)
;; (validation:with-check-validate (image
;; :target-slots target-slots
;; :test test) ((content-type
;; (:assert (find content-type #0='("image/jpeg" "image/png" "image/gif" "image/bmp")
;; :test #'equal)
;; "must be one of ~S but ~S" #0# content-type)))))
;; ;;; Reimplemented in Chapter 13.
;; (defmethod validation:validate validation:validate ((object entry-image)
;; &key target-slots test)
;; (validation:with-check-validate (object
;; :target-slots target-slots
;; :test test)
;; ((entry (:require t)) (filename (:require t)))))
(defmethod validation-validate validation-validate ((image image) &key target-slots test)
(with-check-validate (image)
;; :target-slots target-slots
;; :test test)
((content-type
(:assert (find content-type #0='("image/jpeg" "image/png" "image/gif" "image/bmp")
:test #'equal)
"must be one of ~S but ~S" #0# content-type)))))
;;; Reimplemented in Chapter 13.
(defmethod validation-validate validation-validate ((object entry-image)
&key target-slots test)
(break)
(with-check-validate (object)
;; :target-slots target-slots
;; :test test)
((entry (:require t)) (filename (:require t)))))
(defun seeds()
;; '#(' are ARRAY LITERALS. I keep forgetting this and need to look
;; it up.
(let ((names
#("Taro" "Jiro" "Hana" "John" "Mike" "Sophy" "Bill" "Alex" "Mary" "Tom"))
(fnames ; First Names
#("Hippo" "Darling" "Lopez" "Jerry"))
(gnames ; Given Names
#("Orange" "Fox" "Snake")))
(with-connection (db)
(dotimes (x 10)
(mito:create-dao 'user
:number (+ x 10)
:name (aref names x)
:full-name (format nil "~A ~A"
(aref fnames (rem x 4))
(aref gnames (rem x 3)))
:email (format nil "~A@example.com" (aref names x))
:birthday "1981-12-01"
:sex (nth (rem x 3) '(1 1 2))
;; Removed 'p' from end of :administrator --
;; so the code differs from the code in the
;; tutorial (Chapter 4). I had to change it
;; because it produced errors when trying to
;; seed the database (using 'seeds'
;; function. I have, also, left a note in the
;; 'user' class definition highlighting this.
:administrator (zerop 0)
:password "asagao!"
:filename (when (zerop x) "profile.png")
:content-type (when (zerop x) "image/png")))
;; "#.(" is an ARRAY LITERAL. (Noted in 'Loving Common Lisp' book).
(let ((body #.(with-output-to-string (*standard-output*)
(format t "Morning glory wins.~2%")
(write-line "hgoe hoge boge hoge")
(write-line "fuga fuga guffaug uga")
(write-line "tasdf asdf asdf sadf")))
(now-time (local-time:now)))
(dotimes (x 10)
(mito:create-dao 'article
:title (format nil "Result:~D" x)
:body body
:date-released (local-time:timestamp- now-time (- 8 x) :day)
:date-expired (local-time:timestamp- now-time (- 2 x) :day)
:member-only (zerop 0)))
(dolist (name '("Jiro" "Taro" "Hana"))
(let ((user (mito:find-dao 'user :name name)))
(when user (dotimes (x 10)
(mito:create-dao 'entry
:user user
:title (format nil "Title~D" x)
:body body
:date-posted (local-time:timestamp- now-time (- 10 x) :day)
:status (nth (rem x 3) '("draft" "member-only" "public")))))))
;; PROBLEM IS IN HERE....
(with-open-file (s (merge-pathnames #P"profile.png"
rails-to-caveman.config::*application-root*)
:element-type '(unsigned-byte 8))
(let ((vector (make-array
(file-length s)
:element-type '(unsigned-byte 8))))
(read-sequence vector s)
(storage::write
(make-instance 'flex::vector-input-stream :vector vector) 1 "account"
(storage::make-file :name "profile.png" :content-type "image/png"))
;; PROBLEM IS IN HERE....
))))))
#|
(defun seeds() (with-open-file (s (merge-pathnames "profile.png"
your-app.config::*application-root*)
:element-type '(unsigned-byte 8))
(let ((vector (make-array (file-length s)
:element-type '(unsigned-byte 8))))
(read-sequence vector s)
(storage::write (make-instance 'flex::vector-input-stream
:vector vector) 1 "account"
(storage::make-file :name "profile.png"
:content-type "image/png"))))
(let ((names #("Taro" "Jiro" "Hana" "John" "Mike" "Sophy" "Bill" "Alex" "Mary" "Tom")) ...)
(with-connection (db)
(dotimes (x 10)
(mito:create-dao 'user :number (+ x 10) ...
:password "asagao!"
:filename (when(zerop x) "profile.png")
:content-type (when(zerop x) "image/png") )) ...)))
|#
(defun rebuild ()
"Drops the current database table, recreates it and populates it using seeded data."
(with-connection (db)
(mapc #'mito:ensure-table-exists '(user article entry))
(mapc #'mito:recreate-table '(user article entry)))
(seeds))

604
src/rfc2616-sec10.lisp

@ -0,0 +1,604 @@
;; (in-package :cl-user)
(defpackage #:status-code
(:use :cl)
(:nicknames #:rfc2616-sec10)
(:export +continue+
+switching-protocols+
+ok+
+created+
+accepted+
+non-authoritative-information+
+no-content+
+reset-content+
+partial-content+
+multiple-choices+
+moved-permanently+
+found+
+see-other+
+not-modified+
+use-proxy+
+temporary-redirect+
+bad-request+
+unauthorized+
+payment-required+
+forbidden+
+not-found+
+method-not-allowed+
+not-acceptable+
+proxy-authentication-required+
+request-timeout+
+conflict+
+gone+
+length-required+
+precondition-failed+
+request-entity-too-large+
+request-uri-too-long+
+unsupported-media-type+
+requested-range-not-satisfiable+
+expectation-failed+
+internal-server-error+
+not-implemented+
+bad-gateway+
+service-unavailable+
+gateway-timeout+
+http-version-not-supported+))
(in-package #:status-code)
;;rfc2616-sec10)
(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.")
(DEFCONSTANT +SWITCHING-PROTOCOLS+
101
"The server understands and is willing to comply with the client's
request, via the Upgrade message header field (section 14.42), for a
change in the application protocol being used on this connection. The
server will switch protocols to those defined by the response's
Upgrade header field immediately after the empty line which
terminates the 101 response.
The protocol SHOULD be switched only when it is advantageous to do
so. For example, switching to a newer version of HTTP is advantageous
over older versions, and switching to a real-time, synchronous
protocol might be advantageous when delivering resources that use
such features.")
(DEFCONSTANT +OK+
200
"The request has succeeded. The information returned with the response
is dependent on the method used in the request, for example:
GET an entity corresponding to the requested resource is sent in
the response;
HEAD the entity-header fields corresponding to the requested
resource are sent in the response without any message-body;
POST an entity describing or containing the result of the action;
TRACE an entity containing the request message as received by the
end server.")
(DEFCONSTANT +CREATED+
201
"The request has been fulfilled and resulted in a new resource being
created. The newly created resource can be referenced by the URI(s)
returned in the entity of the response, with the most specific URI
for the resource given by a Location header field. The response
SHOULD include an entity containing a list of resource
characteristics and location(s) from which the user or user agent can
choose the one most appropriate. The entity format is specified by
the media type given in the Content-Type header field. The origin
server MUST create the resource before returning the 201 status code.
If the action cannot be carried out immediately, the server SHOULD
respond with 202 (Accepted) response instead.
A 201 response MAY contain an ETag response header field indicating
the current value of the entity tag for the requested variant just
created, see section 14.19.")
(DEFCONSTANT +ACCEPTED+
202
"The request has been accepted for processing, but the processing has
not been completed. The request might or might not eventually be
acted upon, as it might be disallowed when processing actually takes
place. There is no facility for re-sending a status code from an
asynchronous operation such as this.
The 202 response is intentionally non-committal. Its purpose is to
allow a server to accept a request for some other process (perhaps a
batch-oriented process that is only run once per day) without
requiring that the user agent's connection to the server persist
until the process is completed. The entity returned with this
response SHOULD include an indication of the request's current status
and either a pointer to a status monitor or some estimate of when the
user can expect the request to be fulfilled.")
(DEFCONSTANT +NON-AUTHORITATIVE-INFORMATION+
203
"The returned metainformation in the entity-header is not the
definitive set as available from the origin server, but is gathered
from a local or a third-party copy. The set presented MAY be a subset
or superset of the original version. For example, including local
annotation information about the resource might result in a superset
of the metainformation known by the origin server. Use of this
response code is not required and is only appropriate when the
response would otherwise be 200 (OK).")
(DEFCONSTANT +NO-CONTENT+
204
"The server has fulfilled the request but does not need to return an
entity-body, and might want to return updated metainformation. The
response MAY include new or updated metainformation in the form of
entity-headers, which if present SHOULD be associated with the
requested variant.
If the client is a user agent, it SHOULD NOT change its document view
from that which caused the request to be sent. This response is
primarily intended to allow input for actions to take place without
causing a change to the user agent's active document view, although
any new or updated metainformation SHOULD be applied to the document
currently in the user agent's active view.
The 204 response MUST NOT include a message-body, and thus is always
terminated by the first empty line after the header fields.")
(DEFCONSTANT +RESET-CONTENT+
205
"The server has fulfilled the request and the user agent SHOULD reset
the document view which caused the request to be sent. This response
is primarily intended to allow input for actions to take place via
user input, followed by a clearing of the form in which the input is
given so that the user can easily initiate another input action. The
response MUST NOT include an entity.")
(DEFCONSTANT +PARTIAL-CONTENT+
206
"The server has fulfilled the partial GET request for the resource.
The request MUST have included a Range header field (section 14.35)
indicating the desired range, and MAY have included an If-Range
header field (section 14.27) to make the request conditional.
The response MUST include the following header fields:
- Either a Content-Range header field (section 14.16) indicating
the range included with this response, or a multipart/byteranges
Content-Type including Content-Range fields for each part. If a
Content-Length header field is present in the response, its
value MUST match the actual number of OCTETs transmitted in the
message-body.
- Date
- ETag and/or Content-Location, if the header would have been sent
in a 200 response to the same request
- Expires, Cache-Control, and/or Vary, if the field-value might
differ from that sent in any previous response for the same
variant
If the 206 response is the result of an If-Range request that used a
strong cache validator (see section 13.3.3), the response SHOULD NOT
include other entity-headers. If the response is the result of an
If-Range request that used a weak validator, the response MUST NOT
include other entity-headers; this prevents inconsistencies between
cached entity-bodies and updated headers. Otherwise, the response
MUST include all of the entity-headers that would have been returned
with a 200 (OK) response to the same request.
A cache MUST NOT combine a 206 response with other previously cached
content if the ETag or Last-Modified headers do not match exactly,
see 13.5.4.
A cache that does not support the Range and Content-Range headers
MUST NOT cache 206 (Partial) responses.")
(DEFCONSTANT +MULTIPLE-CHOICES+
300
"The requested resource corresponds to any one of a set of
representations, each with its own specific location, and agent-
driven negotiation information (section 12) is being provided so that
the user (or user agent) can select a preferred representation and
redirect its request to that location.
Unless it was a HEAD request, the response SHOULD include an entity
containing a list of resource characteristics and location(s) from
which the user or user agent can choose the one most appropriate. The
entity format is specified by the media type given in the Content-
Type header field. Depending upon the format and the capabilities of
the user agent, selection of the most appropriate choice MAY be
performed automatically. However, this specification does not define
any standard for such automatic selection.
If the server has a preferred choice of representation, it SHOULD
include the specific URI for that representation in the Location
field; user agents MAY use the Location field value for automatic
redirection. This response is cacheable unless indicated otherwise.")
(DEFCONSTANT +MOVED-PERMANENTLY+
301
"The requested resource has been assigned a new permanent URI and any
future references to this resource SHOULD use one of the returned
URIs. Clients with link editing capabilities ought to automatically
re-link references to the Request-URI to one or more of the new
references returned by the server, where possible. This response is
cacheable unless indicated otherwise.
The new permanent URI SHOULD be given by the Location field in the
response. Unless the request method was HEAD, the entity of the
response SHOULD contain a short hypertext note with a hyperlink to
the new URI(s).
If the 301 status code is received in response to a request other
than GET or HEAD, the user agent MUST NOT automatically redirect the
request unless it can be confirmed by the user, since this might
change the conditions under which the request was issued.
Note: When automatically redirecting a POST request after
receiving a 301 status code, some existing HTTP/1.0 user agents
will erroneously change it into a GET request.")
(DEFCONSTANT +FOUND+
302
"The requested resource resides temporarily under a different URI.
Since the redirection might be altered on occasion, the client SHOULD
continue to use the Request-URI for future requests. This response
is only cacheable if indicated by a Cache-Control or Expires header
field.
The temporary URI SHOULD be given by the Location field in the
response. Unless the request method was HEAD, the entity of the
response SHOULD contain a short hypertext note with a hyperlink to
the new URI(s).
If the 302 status code is received in response to a request other
than GET or HEAD, the user agent MUST NOT automatically redirect the
request unless it can be confirmed by the user, since this might
change the conditions under which the request was issued.
Note: RFC 1945 and RFC 2068 specify that the client is not allowed
to change the method on the redirected request. However, most
existing user agent implementations treat 302 as if it were a 303
response, performing a GET on the Location field-value regardless
of the original request method. The status codes 303 and 307 have
been added for servers that wish to make unambiguously clear which
kind of reaction is expected of the client.")
(DEFCONSTANT +SEE-OTHER+
303
"The response to the request can be found under a different URI and
SHOULD be retrieved using a GET method on that resource. This method
exists primarily to allow the output of a POST-activated script to
redirect the user agent to a selected resource. The new URI is not a
substitute reference for the originally requested resource. The 303
response MUST NOT be cached, but the response to the second
(redirected) request might be cacheable.
The different URI SHOULD be given by the Location field in the
response. Unless the request method was HEAD, the entity of the
response SHOULD contain a short hypertext note with a hyperlink to
the new URI(s).
Note: Many pre-HTTP/1.1 user agents do not understand the 303
status. When interoperability with such clients is a concern, the
302 status code may be used instead, since most user agents react
to a 302 response as described here for 303.")
(DEFCONSTANT +NOT-MODIFIED+
304
"If the client has performed a conditional GET request and access is
allowed, but the document has not been modified, the server SHOULD
respond with this status code. The 304 response MUST NOT contain a
message-body, and thus is always terminated by the first empty line
after the header fields.
The response MUST include the following header fields:
- Date, unless its omission is required by section 14.18.1
If a clockless origin server obeys these rules, and proxies and
clients add their own Date to any response received without one (as
already specified by [RFC 2068], section 14.19), caches will operate
correctly.
- ETag and/or Content-Location, if the header would have been sent
in a 200 response to the same request
- Expires, Cache-Control, and/or Vary, if the field-value might
differ from that sent in any previous response for the same
variant
If the conditional GET used a strong cache validator (see section
13.3.3), the response SHOULD NOT include other entity-headers.
Otherwise (i.e., the conditional GET used a weak validator), the
response MUST NOT include other entity-headers; this prevents
inconsistencies between cached entity-bodies and updated headers.
If a 304 response indicates an entity not currently cached, then the
cache MUST disregard the response and repeat the request without the
conditional.
If a cache uses a received 304 response to update a cache entry, the
cache MUST update the entry to reflect any new field values given in
the response.")
(DEFCONSTANT +USE-PROXY+
305
"The requested resource MUST be accessed through the proxy given by
the Location field. The Location field gives the URI of the proxy.
The recipient is expected to repeat this single request via the
proxy. 305 responses MUST only be generated by origin servers.
Note: RFC 2068 was not clear that 305 was intended to redirect a
single request, and to be generated by origin servers only. Not
observing these limitations has significant security consequences.")
(DEFCONSTANT +TEMPORARY-REDIRECT+
307
"The requested resource resides temporarily under a different URI.
Since the redirection MAY be altered on occasion, the client SHOULD
continue to use the Request-URI for future requests. This response
is only cacheable if indicated by a Cache-Control or Expires header
field.
The temporary URI SHOULD be given by the Location field in the
response. Unless the request method was HEAD, the entity of the
response SHOULD contain a short hypertext note with a hyperlink to
the new URI(s) , since many pre-HTTP/1.1 user agents do not
understand the 307 status. Therefore, the note SHOULD contain the
information necessary for a user to repeat the original request on
the new URI.
If the 307 status code is received in response to a request other
than GET or HEAD, the user agent MUST NOT automatically redirect the
request unless it can be confirmed by the user, since this might
change the conditions under which the request was issued.")
(DEFCONSTANT +BAD-REQUEST+
400
"The request could not be understood by the server due to malformed
syntax. The client SHOULD NOT repeat the request without
modifications.")
(DEFCONSTANT +UNAUTHORIZED+
401
"The request requires user authentication. The response MUST include a
WWW-Authenticate header field (section 14.47) containing a challenge
applicable to the requested resource. The client MAY repeat the
request with a suitable Authorization header field (section 14.8). If
the request already included Authorization credentials, then the 401
response indicates that authorization has been refused for those
credentials. If the 401 response contains the same challenge as the
prior response, and the user agent has already attempted
authentication at least once, then the user SHOULD be presented the
entity that was given in the response, since that entity might
include relevant diagnostic information. HTTP access authentication
is explained in \"HTTP Authentication: Basic and Digest Access
Authentication\" [43].")
(DEFCONSTANT +PAYMENT-REQUIRED+ 402 "This code is reserved for future use.")
(DEFCONSTANT +FORBIDDEN+
403
"The server understood the request, but is refusing to fulfill it.
Authorization will not help and the request SHOULD NOT be repeated.
If the request method was not HEAD and the server wishes to make
public why the request has not been fulfilled, it SHOULD describe the
reason for the refusal in the entity. If the server does not wish to
make this information available to the client, the status code 404
(Not Found) can be used instead.")
(DEFCONSTANT +NOT-FOUND+
404
"The server has not found anything matching the Request-URI. No
indication is given of whether the condition is temporary or
permanent. The 410 (Gone) status code SHOULD be used if the server
knows, through some internally configurable mechanism, that an old
resource is permanently unavailable and has no forwarding address.
This status code is commonly used when the server does not wish to
reveal exactly why the request has been refused, or when no other
response is applicable.")
(DEFCONSTANT +METHOD-NOT-ALLOWED+
405
"The method specified in the Request-Line is not allowed for the
resource identified by the Request-URI. The response MUST include an
Allow header containing a list of valid methods for the requested
resource.")
(DEFCONSTANT +NOT-ACCEPTABLE+
406
"The resource identified by the request is only capable of generating
response entities which have content characteristics not acceptable
according to the accept headers sent in the request.
Unless it was a HEAD request, the response SHOULD include an entity
containing a list of available entity characteristics and location(s)
from which the user or user agent can choose the one most
appropriate. The entity format is specified by the media type given
in the Content-Type header field. Depending upon the format and the
capabilities of the user agent, selection of the most appropriate
choice MAY be performed automatically. However, this specification
does not define any standard for such automatic selection.
Note: HTTP/1.1 servers are allowed to return responses which are
not acceptable according to the accept headers sent in the
request. In some cases, this may even be preferable to sending a
406 response. User agents are encouraged to inspect the headers of
an incoming response to determine if it is acceptable.
If the response could be unacceptable, a user agent SHOULD
temporarily stop receipt of more data and query the user for a
decision on further actions.")
(DEFCONSTANT +PROXY-AUTHENTICATION-REQUIRED+
407
"This code is similar to 401 (Unauthorized), but indicates that the
client must first authenticate itself with the proxy. The proxy MUST
return a Proxy-Authenticate header field (section 14.33) containing a
challenge applicable to the proxy for the requested resource. The
client MAY repeat the request with a suitable Proxy-Authorization
header field (section 14.34). HTTP access authentication is explained
in \"HTTP Authentication: Basic and Digest Access Authentication\"
[43].")
(DEFCONSTANT +REQUEST-TIMEOUT+
408
"The client did not produce a request within the time that the server
was prepared to wait. The client MAY repeat the request without
modifications at any later time.")
(DEFCONSTANT +CONFLICT+
409
"The request could not be completed due to a conflict with the current
state of the resource. This code is only allowed in situations where
it is expected that the user might be able to resolve the conflict
and resubmit the request. The response body SHOULD include enough
information for the user to recognize the source of the conflict.
Ideally, the response entity would include enough information for the
user or user agent to fix the problem; however, that might not be
possible and is not required.
Conflicts are most likely to occur in response to a PUT request. For
example, if versioning were being used and the entity being PUT
included changes to a resource which conflict with those made by an
earlier (third-party) request, the server might use the 409 response
to indicate that it can't complete the request. In this case, the
response entity would likely contain a list of the differences
between the two versions in a format defined by the response
Content-Type.")
(DEFCONSTANT +GONE+
410
"The requested resource is no longer available at the server and no
forwarding address is known. This condition is expected to be
considered permanent. Clients with link editing capabilities SHOULD
delete references to the Request-URI after user approval. If the
server does not know, or has no facility to determine, whether or not
the condition is permanent, the status code 404 (Not Found) SHOULD be
used instead. This response is cacheable unless indicated otherwise.
The 410 response is primarily intended to assist the task of web
maintenance by notifying the recipient that the resource is
intentionally unavailable and that the server owners desire that
remote links to that resource be removed. Such an event is common for
limited-time, promotional services and for resources belonging to
individuals no longer working at the server's site. It is not
necessary to mark all permanently unavailable resources as \"gone\" or
to keep the mark for any length of time -- that is left to the
discretion of the server owner.")
(DEFCONSTANT +LENGTH-REQUIRED+
411
"The server refuses to accept the request without a defined Content-
Length. The client MAY repeat the request if it adds a valid
Content-Length header field containing the length of the message-body
in the request message.")
(DEFCONSTANT +PRECONDITION-FAILED+
412
"The precondition given in one or more of the request-header fields
evaluated to false when it was tested on the server. This response
code allows the client to place preconditions on the current resource
metainformation (header field data) and thus prevent the requested
method from being applied to a resource other than the one intended.")
(DEFCONSTANT +REQUEST-ENTITY-TOO-LARGE+
413
"The server is refusing to process a request because the request
entity is larger than the server is willing or able to process. The
server MAY close the connection to prevent the client from continuing
the request.
If the condition is temporary, the server SHOULD include a Retry-
After header field to indicate that it is temporary and after what
time the client MAY try again.")
(DEFCONSTANT +REQUEST-URI-TOO-LONG+
414
"The server is refusing to service the request because the Request-URI
is longer than the server is willing to interpret. This rare
condition is only likely to occur when a client has improperly
converted a POST request to a GET request with long query
information, when the client has descended into a URI \"black hole\" of
redirection (e.g., a redirected URI prefix that points to a suffix of
itself), or when the server is under attack by a client attempting to
exploit security holes present in some servers using fixed-length
buffers for reading or manipulating the Request-URI.")
(DEFCONSTANT +UNSUPPORTED-MEDIA-TYPE+
415
"The server is refusing to service the request because the entity of
the request is in a format not supported by the requested resource
for the requested method.")
(DEFCONSTANT +REQUESTED-RANGE-NOT-SATISFIABLE+
416
"A server SHOULD return a response with this status code if a request
included a Range request-header field (section 14.35), and none of
the range-specifier values in this field overlap the current extent
of the selected resource, and the request did not include an If-Range
request-header field. (For byte-ranges, this means that the first-
byte-pos of all of the byte-range-spec values were greater than the
current length of the selected resource.)
When this status code is returned for a byte-range request, the
response SHOULD include a Content-Range entity-header field
specifying the current length of the selected resource (see section
14.16). This response MUST NOT use the multipart/byteranges content-
type.")
(DEFCONSTANT +EXPECTATION-FAILED+
417
"The expectation given in an Expect request-header field (see section
14.20) could not be met by this server, or, if the server is a proxy,
the server has unambiguous evidence that the request could not be met
by the next-hop server.")
(DEFCONSTANT +INTERNAL-SERVER-ERROR+
500
"The server encountered an unexpected condition which prevented it
from fulfilling the request.")
(DEFCONSTANT +NOT-IMPLEMENTED+
501
"The server does not support the functionality required to fulfill the
request. This is the appropriate response when the server does not
recognize the request method and is not capable of supporting it for
any resource.")
(DEFCONSTANT +BAD-GATEWAY+
502
"The server, while acting as a gateway or proxy, received an invalid
response from the upstream server it accessed in attempting to
fulfill the request.")
(DEFCONSTANT +SERVICE-UNAVAILABLE+
503
"The server is currently unable to handle the request due to a
temporary overloading or maintenance of the server. The implication
is that this is a temporary condition which will be alleviated after
some delay. If known, the length of the delay MAY be indicated in a
Retry-After header. If no Retry-After is given, the client SHOULD
handle the response as it would for a 500 response.
Note: The existence of the 503 status code does not imply that a
server must use it when becoming overloaded. Some servers may wish
to simply refuse the connection.")
(DEFCONSTANT +GATEWAY-TIMEOUT+
504
"The server, while acting as a gateway or proxy, did not receive a
timely response from the upstream server specified by the URI (e.g.
HTTP, FTP, LDAP) or some other auxiliary server (e.g. DNS) it needed
to access in attempting to complete the request.
Note: Note to implementors: some deployed proxies are known to
return 400 or 500 when DNS lookups time out.")
(DEFCONSTANT +HTTP-VERSION-NOT-SUPPORTED+
505
"The server does not support, or refuses to support, the HTTP protocol
version that was used in the request message. The server is
indicating that it is unable or unwilling to complete the request
using the same major version as the client, as described in section
3.1, other than with this error message. The response SHOULD contain
an entity describing why that version is not supported and what other
protocols are supported by that server.")

73
src/storage.lisp

@ -0,0 +1,73 @@
;;; (in-package :cl-user)
(defpackage #:rails-to-caveman.storage
(:use #:cl)
(:shadow #:write
#:read
#:remove
#:probe-file))
(in-package #:rails-to-caveman.storage)
(defstruct (file (:type vector))
name
size
content-type)
(defun prin1-to-base64-string (object)
;;; SOMETHING IS CALLING THIS AND NOT PROPERLY. YOU ARE UP TO HERE.
(cl-base64:string-to-base64-string (prin1-to-string object)))
(defun read-from-base64-string(string)
(values (read-from-string
(cl-base64:base64-string-to-string string))))
(defun make-storage-pathname (id subdirectory &optional file)
(merge-pathnames (format nil "storage/~A/~A/~@[~A~]"
id
subdirectory
(when file (prin1-to-base64-string file)))
rails-to-caveman.config::*application-root*))
(defun write (stream id subdirectory file)
;; (let ((path (ensure-directories-exist
;; (make-storage-pathname id subdirectory file))))
(let ((path "/home/craig/Desktop/test.png"))
(with-open-file (s path
:direction :output
:if-does-not-exist :create
:element-type '(unsigned-byte 8)
:if-exists nil)
(write-sequence (slot-value stream 'vector) s :start 0))))
;; (if s
;; (write-sequence (slot-value stream 'vector) s)
;; (warn "File already exists ~S~&Ignored." path))))
(defun read (id subdirectory file)
(with-open-file (s (make-storage-pathname id subdirectory file)
:element-type '(unsigned-byte 8))
(let* ((length (file-length s))
(buffer (make-array length
:element-type '(unsigned-byte 8))))
(read-sequence buffer s)
(values buffer length))))
(defun remove (id subdirectory file)
(delete-file (make-storage-pathname id subdirectory file)))
(defun probe-file (id subdirectory file)
(cl:probe-file (make-storage-pathname id subdirectory file)))
;;; This function requires ImageMagick so you will need to install it
;;; with 'sudo apt install imagemagick' (assuming you are on a
;;; Debian-based system).
(defun convert (id subdirectory original-file converted-file)
(let ((command (format nil "convert -geometry ~A ~A ~A"
(file-size converted-file)
(make-storage-pathname id subdirectory original-file)
(make-storage-pathname id subdirectory converted-file))))
(let ((message (nth-value 1
(uiop:run-program command
:ignore-error-status t
:error-output :string))))
(when message (error message)))))

596
src/web.lisp

@ -7,7 +7,11 @@
#:rails-to-caveman.model
#:sxql
#:mito
#:cl-who)
#:rails-to-caveman.storage
#:cl-who
;; #:rails-to-caveman.helpers
#:status-code)
;; #:rfc2616-sec10)
(:import-from #:rails-to-caveman.db
#:connection-settings
#:db
@ -32,8 +36,7 @@
(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))
:user,(when (hermetic:logged-in-p) (current-user))
,@(roles)
:token ,(token)
:alert ,(flash-gethash :alert ningle:*session*)
@ -260,21 +263,84 @@ nil "/users/~D"(mito:object-id 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)
(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))))))
(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)))))))))))
;;; 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
@ -520,54 +586,278 @@ nil "/users/~D"(mito:object-id user))))))))
: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)
(&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"))))))))))
(&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 ())
@ -889,6 +1179,43 @@ nil "/users/~D"(mito:object-id user))))))))
(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")))
@ -1246,3 +1573,156 @@ worse of all the chapters I have read up to now.
`(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)))))

3
templates/accounts/edit.html

@ -10,7 +10,8 @@
<a href="/account">Go back my account</a>
</div>
<form class="edit_account" id="edit_account" action="/account" method="post">
<form class="edit_account" id="edit_account" action="/account"
method="post" enctype="multipart/form-data">
<input type="hidden" name="METHOD" value="post">
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}">
{% include "users/form.html" %}

3
templates/entries/footer.html

@ -3,7 +3,8 @@
<li>{{entry.status}}</li>
{% ifequal user.id member.id %}
<a href="/entries/{{entry.id}}/edit">Edit</a>
<a href="/entries/{{entry.id}}/images">Images</a>
<form action="/entries/{{entry.id}}" method="post">
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}">
<input type="hidden" name="METHOD" value="delete">

29
templates/entries/show.html

@ -2,16 +2,31 @@
{% block title %}
{{ entry
| lisp: (lambda(entry)
(title! (format nil "~A - ~A San's blog"
(rails-to-caveman.model::title-of entry)
(rails-to-caveman.model::name-of (rails-to-caveman.model::author-of entry)))))
}}
| lisp: (lambda(entry)
(title! (format nil "~A - ~A San's blog"
(rails-to-caveman.model::title-of entry)
(rails-to-caveman.model::name-of (rails-to-caveman.model::author-of entry)))))
}}
{% endblock %}
{% block content %}
<h1>{% lisp (title!) %}</h1>
<h2>{{entry.title}}</h2>
{% if images.first %}
<div>
<img alt="{{images.first.alt-text}}"
style="display: block; margin: 0 auto 15px"
src="/storage/{{user.id}}/entry{{entry.id}}/{{images.first.filename}}?CONTENT-TYPE={{images.first.content-type}}"/>
</div>
{% endif %}
{{ entry.body | simple-format | safe }}
{% include "entries/footer.html" %}
{% endblock %}
{% if images.rest %}
{% for image in images.rest %}
<div>
<img alt="{{image.alt-text}}"
style="display: block; margin: 0 auto 15px"
src="/storage/{{user.id}}/entry{{entry.id}}/{{image.filename}}?CONTENT-TYPE={{image.content-type}}"/>
</div>
{% endfor %}
{% endif %}

15
templates/entry-images/edit.html

@ -0,0 +1,15 @@
{% extends "layouts/app.html" %}
{% block title %}{% lisp (title! "Edit image") %}{% endblock %}
{% block content %}
<h1>{% lisp (title!) %}</h1>
<h2>{{entry.title}}</h2>
<form action="/entries/{{entry.id}}/images/{{image.id}}" method="post" enctype="multipart/form-data">
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}"/>
<input type="hidden" name="METHOD" value="post"/>
{% include "entry-images/form.html" %}
<div><input type="submit" value="Update" /></div>
</form>
{% endblock %}

11
templates/entry-images/form.html

@ -0,0 +1,11 @@
{% include "shared/errors.html" %}
<table class="attr">
<tr>
<th><label for="image-new-data">New data</label></th>
<td><input type="file" name="IMAGE" id="image-new-data"/></td>
</tr>
<tr>
<th><label for="image-alt-text">Alt text</label></th>
<td><input type="text" name="ALT-TEXT" value="{{image.alt-text}}" id="image-alt-text" size="40"/></td>
</tr>
</table>

50
templates/entry-images/index.html

@ -0,0 +1,50 @@
{% extends "layouts/app.html" %}
{% block title %}{% lisp (title! "Entry images") %}{% endblock %}
{% block content %}
<h1>{% lisp (title!) %}</h1>
<h2>{{ entry.title }}</h2>
<ul class="toolbar">
<a href="/entries/{{entry.id}}">Go back entry</a>
<a href="/entries/{{entry.id}}/images/new">Add image</a>
</ul>
{% if images %}
<table class="list">
<thead>
<tr>
<th>Number</th>
<th>Image</th>
<th>Alt text</th>
<th>Operation</th>
</tr>
</thead>
<tbody>
{% for (image . index) in images %}
<tr>
<td>{{index}}</td>
<td>
<img src="/storage/{{user.id}}/entry{{entry.id}}/{{image.filename}}?CONTENT-TYPE={{image.content-type}}&SIZE=100x100" alt="{{image.alt-text}}">
</td>
<td>{{image.alt-text}}</td>
<td>
<div>
<a href="/entries/{{entry.id}}/images/{{image.id}}/edit">Edit</a>
<form action="/entries/{{entry.id}}/images/{{image.id}}" method="post">
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}">
<input type="hidden" name="METHOD" value="delete">
<input type="submit" value="Delete">
</form>
</div>
</td>
</tr>
{% endfor %}
</tbody>
</table>
{% else %}
<p>No images</p>
{% endif %}
{% endblock %}

16
templates/entry-images/new.html

@ -0,0 +1,16 @@
{% extends "layouts/app.html" %}
{% block title %}{% lisp (title! "Add image") %}{% endblock %}
{% block content %}
<h1>{% lisp (title!) %}</h1>
<h2>{{entry.title}}</h2>
<form action="/entries/{{entry.id}}/images" method="post" enctype="multipart/form-data">
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}">
<input type="hidden" name="METHOD" value="put">
{% include "entry-images/form.html" %}
<div><input type="submit" value="Add"/></div>
</form>
{% endblock %}

20
templates/shared/user_form.html

@ -1,4 +1,10 @@
{% if user.id %}
<div>
<img src="/storage/{{user.id}}/account/{{user.filename}}?CONTENT-TYPE={{user.content-type}}&SIZE=128x128">
<label for="remove-profile-image-p">Remove profile image</label>
<input type="checkbox" name="REMOVE-PROFILE-IMAGE-P" id="remove-profile-image-p">
</div>
<tr>
<th><label for="password">Password</label></th>
<td><input id="password" type="text" name="PASSWORD" /></td>
@ -14,5 +20,17 @@
</td>
</tr>
{% endif %}
</table>
<tr>
<th><label for="profile-image">Profile image</label></th>
<td>
<div><input type="file" name="IMAGE" id="profile-image"/></div>
{% if user.filename %}
<div>
<img src="/storage/{{user.id}}/account/{{user.filename}}?CONTENT-TYPE={{user.content-type}}&SIZE=128x128">
</div>
{% endif %}
</td>
</tr>
<tr>
</table>

96
templates/users/body.html

@ -1,46 +1,54 @@
<table class="attr">
<tr>
<th width="150">Number</th>
<td>{{user.number}}</td>
</tr>
<tr>
<th>Name</th>
<td>{{user.name}}</td>
</tr>
<tr>
<th>Full name</th>
<td>{{user.full-name}}</td>
</tr>
<tr>
<th>Sex</th>
<td>
{% ifequal user.sex 1 %}
Male
{% else %}
Female
{% endifequal %}
</td>
</tr>
<tr>
<th>Birthday</th>
<td>
{{ user.birthday|
lisp: local-time:timestamp-to-universal|
date: ((:year 4)"/"(:month 2)"/"(:day 2)) }}
</td>
</tr>
<tr>
<th>Mail adress</th>
<td>{{user.email}}</td>
</tr>
<tr>
<th>administrator</th>
<td>
{% if user.administrator %}
Yes
{% else %}
No
{% endif %}
</td>
</tr>
<tr>
<th>Profile image</th>
<td>
{% if user.filename %}
<img src="/storage/{{user.id}}/account/{{user.filename}}?CONTENT-TYPE={{user.content-type}}&SIZE=128x128">
{% endif %}
</td>
<tr>
<tr>
<th width="150">Number</th>
<td>{{user.number}}</td>
</tr>
<tr>
<th>Name</th>
<td>{{user.name}}</td>
</tr>
<tr>
<th>Full name</th>
<td>{{user.full-name}}</td>
</tr>
<tr>
<th>Sex</th>
<td>
{% ifequal user.sex 1 %}
Male
{% else %}
Female
{% endifequal %}
</td>
</tr>
<tr>
<th>Birthday</th>
<td>
{{ user.birthday|
lisp: local-time:timestamp-to-universal|
date: ((:year 4)"/"(:month 2)"/"(:day 2)) }}
</td>
</tr>
<tr>
<th>Mail adress</th>
<td>{{user.email}}</td>
</tr>
<tr>
<th>administrator</th>
<td>
{% if user.administrator %}
Yes
{% else %}
No
{% endif %}
</td>
</tr>
</table>

2
templates/users/edit.html

@ -10,7 +10,7 @@
<a href="/users/{{user.id}}">Back to user detail</a>
</div>
<form class="edit-user" id="edit-user"
<form class="edit-user" id="edit-user" enctype="multipart/form-data"
action="/user/{{user.id}}" method="post">
<input name="_method" type="hidden" value="patch"/>
<input name="authenticity-token" type="hidden" value="{{token}}"/>

3
templates/users/new.html

@ -6,7 +6,8 @@
{% block content %}
<h1>{% lisp (title!) %}</h1>
<p>{{user}}</p>
<form class="new-user" id="new-user" action="/user" method="post">
<form class="new-user" id="new-user" action="/user" method="post"
enctype="multipart/form-data">
<!-- Method and Authenticity-token need to be in capitals -->
<input name="AUTHENTICITY-TOKEN" type="hidden" value="{{token}}"/>
<input name="METHOD" type="hidden" value="put" />

Loading…
Cancel
Save