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.
133 lines
4.7 KiB
133 lines
4.7 KiB
2 years ago
|
#| 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+))))))
|