src/components.lisp

   1 (uiop:define-package #:lw2.components
   2   (:use #:cl #:alexandria #:lw2.utils #:lw2.csrf)
   3   (:export
   4    #:standard-component #:prepare-function
   5    #:make-binding-form
   6    #:&without-csrf-check
   7    #:wrap-prepare-code
   8    #:find-component #:delete-component #:define-component #:renderer
   9    #:component-value-bind)
  10   (:unintern
  11    #:standard-component #:wrap-http-bindings))
  12
  13 (in-package #:lw2.components)
  14
  15 (defvar *components* nil)
  16
  17 (defun make-binding-form (additional-vars body &aux var-bindings additional-declarations additional-preamble)
  18   (loop for x in additional-vars
  19      when (not (member (first (ensure-list x)) '(* &without-csrf-check)))
  20      do
  21        (destructuring-bind (name &key member type default required (request-type '(:post :get)) (real-name (string-downcase name)) passthrough)
  22            (ensure-list x)
  23          (let* ((inner-form
  24                  (if passthrough
  25                      name
  26                      `(or ,.(mapcar (lambda (rt)
  27                                       (list (if (eq rt :post) 'hunchentoot:post-parameter 'hunchentoot:get-parameter)
  28                                             real-name))
  29                                     (ensure-list request-type)))))
  30                 (inner-form
  31                  (cond
  32                    (member
  33                     `(let* ((raw-value ,inner-form)
  34                             (sym (find-symbol (string-upcase raw-value) ,(find-package '#:keyword))))
  35                        (when raw-value
  36                          (if (member sym ,member)
  37                              sym
  38                              (error "The ~A parameter has an unrecognized value." ',name)))))
  39                    ((and type (subtypep type 'integer))
  40                     `(let ((,name ,inner-form))
  41                        (declare (type (or null simple-string) ,name))
  42                        (if ,name (parse-integer ,name))))
  43                    (t inner-form)))
  44                 (inner-form
  45                  (if (eq type 'boolean)
  46                      `(let ((,name ,inner-form))
  47                         (if ,name
  48                             (truthy-string-p ,name)
  49                             ,default))
  50                      (if default
  51                          `(or ,inner-form ,default)
  52                          inner-form))))
  53            (when required
  54              (push `(unless (and ,name (not (equal ,name ""))) (error "Missing required parameter: ~A" ,real-name))
  55                    additional-preamble))
  56            (if member
  57                (if type (error "Cannot specify both member and type.")
  58                    (push `(type (or null symbol) ,name) additional-declarations))
  59                (if type
  60                    (push `(type (or null ,type) ,name) additional-declarations)
  61                    (push `(type (or null simple-string) ,name) additional-declarations)))
  62            (when inner-form
  63              (push `(,name ,inner-form) var-bindings)))))
  64   `(progn
  65      ,@(unless (member '&without-csrf-check additional-vars)
  66          '((check-csrf)))
  67      (let ,(nreverse var-bindings)
  68        (declare ,.(nreverse additional-declarations))
  69        ,.(nreverse additional-preamble)
  70        (block nil ,@body))))
  71
  72 (defun wrap-prepare-code (http-args lambda-list body)
  73   (with-gensyms (renderer-callback)
  74     `(lambda (,renderer-callback ,@lambda-list)
  75        (macrolet ((renderer ((&rest lambda-list) &body body)
  76                     `(funcall ,',renderer-callback (lambda ,lambda-list (block nil (locally ,@body))))))
  77          ,(make-binding-form http-args body)))))
  78
  79 (defun find-component (name)
  80   (or (second (find name *components* :key #'car))
  81       (error "Undefined component: ~A" name)))
  82
  83 (defun delete-component (name)
  84   (setf *components* (delete name *components* :key #'car)))
  85
  86 (defmacro define-component (name lambda-list (&key http-args) &body body)
  87   `(progn
  88      (let ((component
  89             (alist :prepare-function ,(wrap-prepare-code http-args lambda-list body))))
  90        (delete-component ',name)
  91        (push (list ',name component) *components*))))
  92
  93 (defun prepare-function (component)
  94   (cdr (assoc :prepare-function component)))
  95
  96 (defmacro component-value-bind ((&rest binding-forms) &body body)
  97   (let ((output-form `(locally ,@body)))
  98     (dolist (b (reverse binding-forms))
  99       (destructuring-bind (binding-vars prepare-form &key as) b
 100         (destructuring-bind (name &rest args) (ensure-list prepare-form)
 101           (let ((binding-vars (ensure-list binding-vars)))
 102             (setf output-form
 103                   `(let ((,(or as name) nil))
 104                      (multiple-value-bind ,binding-vars (funcall (load-time-value (prepare-function (find-component ',name)))
 105                                                                  (lambda (renderer) (setf ,(or as name) renderer))
 106                                                                  ,@args)
 107                        ,output-form)))))))
 108     output-form))