You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
132 lines
4.7 KiB
132 lines
4.7 KiB
#| 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+))))))
|
|
|