Skip to content

Instantly share code, notes, and snippets.

@jlouiss
Created July 15, 2020 17:04
Show Gist options
  • Save jlouiss/2aec6a010bfafcbd4667b6da525e5a23 to your computer and use it in GitHub Desktop.
Save jlouiss/2aec6a010bfafcbd4667b6da525e5a23 to your computer and use it in GitHub Desktop.
Credit: Practical Common Lisp
(in-package :com.gigamonkeys.url-function)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; API
(defmacro define-url-function (name (request &rest params) &body body)
(with-gensyms (entity)
(let ((params (mapcar #'normalize-param params)))
`(progn
(defun ,name (,request ,entity)
(with-http-response (,request ,entity :content-type "text/html")
(let* (,@(param-bindings name request params))
,@(set-cookies-code name request params)
(with-http-body (,request ,entity)
(with-html-output ((request-reply-stream ,request))
(html ,@body))))))
(publish :path ,(format nil "/~(~a~)" name) :function ',name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler code
(defun normalize-param (param)
(etypecase param
(list param)
(symbol `(,param string nil nil))))
(defun param-bindings (function-name request params)
(loop for param in params
collect (param-binding function-name request param)))
(defun param-binding (function-name request param)
(destructuring-bind (name type &optional default sticky) param
(let ((query-name (symbol->query-name name))
(cookie-name (symbol->cookie-name function-name name sticky)))
`(,name (or
(string->type ',type (request-query-value ,query-name ,request))
,@(if cookie-name
(list `(string->type ',type (get-cookie-value ,request ,cookie-name))))
,default)))))
(defun symbol->query-name (sym)
(string-downcase sym))
(defun symbol->cookie-name (function-name sym sticky)
(let ((package-name (package-name (symbol-package function-name))))
(when sticky
(ecase sticky
(:global
(string-downcase sym))
(:package
(format nil "~(~a:~a~)" package-name sym))
(:local
(format nil "~(~a:~a:~a~)" package-name function-name sym))))))
(defun set-cookies-code (function-name request params)
(loop for param in params
when (set-cookie-code function-name request param) collect it))
(defun set-cookie-code (function-name request param)
(destructuring-bind (name type &optional default sticky) param
(declare (ignore type default))
(if sticky
`(when ,name
(set-cookie-header
,request
:name ,(symbol->cookie-name function-name name sticky)
:value (princ-to-string ,name))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Runtime
(defgeneric string->type (type value))
(defmethod string->type ((type (eql 'string)) value)
(and (plusp (length value)) value))
(defun get-cookie-value (request name)
(cdr (assoc name (get-cookie-values request) :test #'string=)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment