diff --git a/profile.png b/profile.png new file mode 100644 index 0000000..d41c9c9 Binary files /dev/null and b/profile.png differ diff --git a/rails-to-caveman.asd b/rails-to-caveman.asd index 3b0fde3..848f7aa 100644 --- a/rails-to-caveman.asd +++ b/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")))) diff --git a/src/ch12.5.lisp b/src/ch12.5.lisp new file mode 100644 index 0000000..759226f --- /dev/null +++ b/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+)))))) diff --git a/src/helpers.lisp b/src/helpers.lisp new file mode 100644 index 0000000..fea97b9 --- /dev/null +++ b/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+)))))) diff --git a/src/model.lisp b/src/model.lisp index 340de0d..2d2482e 100644 --- a/src/model.lisp +++ b/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)) diff --git a/src/rfc2616-sec10.lisp b/src/rfc2616-sec10.lisp new file mode 100644 index 0000000..f90d2c6 --- /dev/null +++ b/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.") diff --git a/src/storage.lisp b/src/storage.lisp new file mode 100644 index 0000000..987ad4b --- /dev/null +++ b/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))))) + + diff --git a/src/web.lisp b/src/web.lisp index 6518b42..41156ab 100644 --- a/src/web.lisp +++ b/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))))) diff --git a/templates/accounts/edit.html b/templates/accounts/edit.html index 433057e..d577c8e 100644 --- a/templates/accounts/edit.html +++ b/templates/accounts/edit.html @@ -10,7 +10,8 @@ Go back my account -
+ {% include "users/form.html" %} diff --git a/templates/entries/footer.html b/templates/entries/footer.html index 1e551a0..13a4d05 100644 --- a/templates/entries/footer.html +++ b/templates/entries/footer.html @@ -3,7 +3,8 @@
  • {{entry.status}}
    • {% ifequal user.id member.id %} Edit - + Images + diff --git a/templates/entries/show.html b/templates/entries/show.html index 5951d33..e410638 100644 --- a/templates/entries/show.html +++ b/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 %}

    {% lisp (title!) %}

    {{entry.title}}

    + +{% if images.first %} +
    + {{images.first.alt-text}} +
    +{% endif %} {{ entry.body | simple-format | safe }} -{% include "entries/footer.html" %} -{% endblock %} +{% if images.rest %} +{% for image in images.rest %} +
    + {{image.alt-text}} +
    +{% endfor %} +{% endif %} diff --git a/templates/entry-images/edit.html b/templates/entry-images/edit.html new file mode 100644 index 0000000..d3716d1 --- /dev/null +++ b/templates/entry-images/edit.html @@ -0,0 +1,15 @@ +{% extends "layouts/app.html" %} + +{% block title %}{% lisp (title! "Edit image") %}{% endblock %} + +{% block content %} +

    {% lisp (title!) %}

    +

    {{entry.title}}

    + + + + + {% include "entry-images/form.html" %} +
    +
    +{% endblock %} diff --git a/templates/entry-images/form.html b/templates/entry-images/form.html new file mode 100644 index 0000000..396978f --- /dev/null +++ b/templates/entry-images/form.html @@ -0,0 +1,11 @@ +{% include "shared/errors.html" %} + + + + + + + + + +
    diff --git a/templates/entry-images/index.html b/templates/entry-images/index.html new file mode 100644 index 0000000..a49a167 --- /dev/null +++ b/templates/entry-images/index.html @@ -0,0 +1,50 @@ +{% extends "layouts/app.html" %} + +{% block title %}{% lisp (title! "Entry images") %}{% endblock %} + +{% block content %} +

    {% lisp (title!) %}

    +

    {{ entry.title }}

    + + + +{% if images %} + + + + + + + + + + + {% for (image . index) in images %} + + + + + + + {% endfor %} + +
    NumberImageAlt textOperation
    {{index}} + {{image.alt-text}} + {{image.alt-text}} +
    + Edit +
    + + + +
    +
    +
    +{% else %} +

    No images

    +{% endif %} +{% endblock %} + diff --git a/templates/entry-images/new.html b/templates/entry-images/new.html new file mode 100644 index 0000000..3db5159 --- /dev/null +++ b/templates/entry-images/new.html @@ -0,0 +1,16 @@ +{% extends "layouts/app.html" %} + +{% block title %}{% lisp (title! "Add image") %}{% endblock %} + +{% block content %} +

    {% lisp (title!) %}

    +

    {{entry.title}}

    + +
    + + + {% include "entry-images/form.html" %} +
    +
    + +{% endblock %} diff --git a/templates/shared/user_form.html b/templates/shared/user_form.html index 24d8693..3130259 100644 --- a/templates/shared/user_form.html +++ b/templates/shared/user_form.html @@ -1,4 +1,10 @@ {% if user.id %} +
    + + + +
    + @@ -14,5 +20,17 @@ {% endif %} - + + + +
    + {% if user.filename %} +
    + +
    + {% endif %} + + + + diff --git a/templates/users/body.html b/templates/users/body.html index 21827ed..673a658 100644 --- a/templates/users/body.html +++ b/templates/users/body.html @@ -1,46 +1,54 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Number{{user.number}}
    Name{{user.name}}
    Full name{{user.full-name}}
    Sex - {% ifequal user.sex 1 %} - Male - {% else %} - Female - {% endifequal %} -
    Birthday - {{ user.birthday| - lisp: local-time:timestamp-to-universal| - date: ((:year 4)"/"(:month 2)"/"(:day 2)) }} -
    Mail adress{{user.email}}
    administrator - {% if user.administrator %} - Yes - {% else %} - No - {% endif %} -
    Profile image + {% if user.filename %} + + {% endif %} +
    Number{{user.number}}
    Name{{user.name}}
    Full name{{user.full-name}}
    Sex + {% ifequal user.sex 1 %} + Male + {% else %} + Female + {% endifequal %} +
    Birthday + {{ user.birthday| + lisp: local-time:timestamp-to-universal| + date: ((:year 4)"/"(:month 2)"/"(:day 2)) }} +
    Mail adress{{user.email}}
    administrator + {% if user.administrator %} + Yes + {% else %} + No + {% endif %} +
    diff --git a/templates/users/edit.html b/templates/users/edit.html index 8926316..624b165 100644 --- a/templates/users/edit.html +++ b/templates/users/edit.html @@ -10,7 +10,7 @@ Back to user detail -
    diff --git a/templates/users/new.html b/templates/users/new.html index d816fe0..4e50610 100644 --- a/templates/users/new.html +++ b/templates/users/new.html @@ -6,7 +6,8 @@ {% block content %}

    {% lisp (title!) %}

    {{user}}

    - +