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