Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: bf7ab7f7e0
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 91 lines (78 sloc) 3.216 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
(in-package #:tpd2.webapp)

(defvar *webapp-frame*)
(define-constant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame.")
  :test 'equalp)

(define-constant +web-safe-chars+
  (force-byte-vector
   (append (loop for c from (char-code #\A) to (char-code #\Z) collect c)
(loop for c from (char-code #\a) to (char-code #\z) collect c)
(loop for c from (char-code #\0) to (char-code #\9) collect c)
(mapcar 'char-code '(#\- #\_))))
  :test 'equalp)

(defun generate-args-for-defpage-from-params (params-var defaulting-lambda-list)
  (let ((arg-names (mapcar 'force-first defaulting-lambda-list))
(arg-values (mapcar (lambda(x)(second (force-list x))) defaulting-lambda-list)))
    (loop for name in arg-names
for value in arg-values
collect (intern (force-string name) :keyword)
if (eq name 'all-http-params)
collect params-var
else
collect `(or (alist-get ,params-var ,(force-byte-vector name)
:test 'byte-vector=-fold-ascii-case)
,value))))

(defmacro with-webapp-frame ((con params) &body body)
  (check-symbols params con)
  `(let ((*webapp-frame*
(awhen (alist-get ,params +webapp-frame-id-param+ :test 'byte-vector=-fold-ascii-case)
(find-frame it))))
     (setf (frame-trace-info (webapp-frame :site (current-site))) (con-peer-info con))
     (frame-reset-timeout (webapp-frame))
     (locally
,@body)))

(defmacro apply-page-call (con function &rest args)
  (let* ((defaulting-lambda-list (car (last args)))
(normal-args (butlast args)))
    `(with-webapp-frame (,con all-http-params)
       (funcall ,function ,@normal-args ,@(generate-args-for-defpage-from-params 'all-http-params defaulting-lambda-list)))))


(defmacro defpage-lambda (path function &optional defaulting-lambda-list)
  `(dispatcher-register-path (site-dispatcher (current-site)) ,path
(lambda(dispatcher con done path all-http-params)
(declare (ignore dispatcher path))
(multiple-value-bind (body headers)
(apply-page-call con ,function ,defaulting-lambda-list)
(respond-http con done :body body :headers headers)))))

(defmacro defpage (path defaulting-lambda-list &body body)
  (let ((normal-func-name (intern (strcat 'page-
(typecase path
((or string byte-vector) path)
(t ()))))))
    `(progn
       (defun ,normal-func-name (&key ,@defaulting-lambda-list)
,@body)
       (defpage-lambda
,path ',normal-func-name ,defaulting-lambda-list)
       ',normal-func-name)))

(defmacro page-link (&optional (page '+action-page-name+) &rest args)
  `(sendbuf-to-byte-vector
    (with-sendbuf (sendbuf)
      ,page
      "?.unique.="
      (random-web-sparse-key 4)
      "&"
      +webapp-frame-id-param+
      "="
      (awhen *webapp-frame*
(frame-id it))
      ,@(loop for (param val) on args by #'cddr
collect "&"
collect (symbol-name param)
collect "="
collect `(percent-hexpair-encode ,val)))))

(defun-speedy random-web-safe-char ()
  (aref +web-safe-chars+ (random (length +web-safe-chars+))))


(defun random-web-sparse-key (length)
  (let ((bv (make-byte-vector length)))
    (loop for i from 0 below length
do (setf (aref bv i) (random-web-safe-char)))
    bv))
Something went wrong with that request. Please try again.