103 lines
3.4 KiB
Common Lisp
103 lines
3.4 KiB
Common Lisp
(defpackage :ywatds-server-wrapper
|
|
(:use :cl)
|
|
(:nicknames :ywsw)
|
|
(:export :toxml :wrap-html :defsafe
|
|
:safe-text-route :safe-json-route :safe-graphviz-route))
|
|
(in-package :ywsw)
|
|
|
|
(defmacro with-content-type (ctype &body body)
|
|
`(progn (setf (hunchentoot:content-type*) ,ctype) ,@body))
|
|
|
|
(defun toxml (l)
|
|
(cond
|
|
((null l) "")
|
|
((listp l)
|
|
(let ((tag (car l)) (attrs (cadr l)) (body (cddr l)))
|
|
(format nil "<~a~@[~{ ~a~@[='~a'~]~}~]~:[/~;~:*>~{~a~}<~0@*/~a~]>"
|
|
tag attrs
|
|
(loop for i in body collect (toxml i)))))
|
|
((eql t l) "true")
|
|
(t (format nil "~a" l))))
|
|
|
|
(defmacro toxml-multiple (&body body)
|
|
`(concatenate 'string ,@(loop for i in body collect `(toxml ,i))))
|
|
|
|
(defmacro wrap-html (title &body body)
|
|
`(progn
|
|
(setf (hunchentoot:content-type*) "text/html")
|
|
(toxml
|
|
`("html" ()
|
|
("head" () ("title" () ,,title))
|
|
("body" () ,,@body)))))
|
|
|
|
;; Lazy error handler: deny access if error occurs
|
|
(defmacro safe-route (&body body)
|
|
(let ((c (gensym)))
|
|
`(handler-case (progn ,@body)
|
|
(file-error (,c)
|
|
(setf (hunchentoot:return-code*) 404)
|
|
(hunchentoot:log-message* :error (format nil "~a" ,c))
|
|
nil)
|
|
(t (,c)
|
|
(setf (hunchentoot:return-code*) 403)
|
|
(hunchentoot:log-message* :error (format nil "~a" ,c))
|
|
nil))))
|
|
|
|
(defmacro defsafe (name options params &body body)
|
|
`(easy-routes:defroute ,name ,options ,params (safe-route ,@body)))
|
|
|
|
(defmacro with-documentation ((name options params desc) &body body)
|
|
(alexandria:with-gensyms (docroute)
|
|
(let ((lowername (string-downcase (string name)))
|
|
(path (cl-ppcre:regex-replace-all
|
|
":([^:/]+)"
|
|
(if (listp options) (car options) options)
|
|
"</b><i>\\1</i><b>")))
|
|
`(progn
|
|
(defsafe
|
|
,docroute ,(format nil "/doc/http-~a" lowername) ()
|
|
(wrap-html
|
|
,(format nil "API ~a" lowername)
|
|
,(toxml-multiple
|
|
`("h2" () (i () "API ") ,lowername)
|
|
`("h3" () (b () "Path and parameters"))
|
|
`("p" () (b () ,path)
|
|
,@(loop for ent in params
|
|
for i = (string-downcase (string (if (listp ent) (car ent) ent)))
|
|
collect " "
|
|
collect
|
|
(if (char= #\& (char i 0))
|
|
(let ((sym (subseq i 1)))
|
|
(format nil "&~a" sym))
|
|
`("i" () ,i))))
|
|
`("h3" () (b () "Description"))
|
|
`("p" () ,@desc))))
|
|
,@body))))
|
|
|
|
(defmacro safe-text-route (name options params doc &body body)
|
|
(let ((response (gensym)))
|
|
`(with-documentation (,name ,options ,params ,doc)
|
|
(easy-routes:defroute
|
|
,name ,options ,params
|
|
(setf (hunchentoot:content-type*) "text/plain")
|
|
(let ((,response (safe-route ,@body)))
|
|
(if (stringp ,response) ,response nil))))))
|
|
|
|
(defmacro safe-json-route (name options params doc &body body)
|
|
(alexandria:with-gensyms (response)
|
|
`(with-documentation (,name ,options ,params ,doc)
|
|
(easy-routes:defroute
|
|
,name ,options ,params
|
|
(setf (hunchentoot:content-type*) "application/json")
|
|
(let ((,response (safe-route (json:encode-json-to-string (progn ,@body)))))
|
|
(if (stringp ,response) ,response "null"))))))
|
|
|
|
(defmacro safe-graphviz-route (name options params doc &body body)
|
|
(alexandria:with-gensyms (response)
|
|
`(with-documentation (,name ,options ,params ,doc)
|
|
(easy-routes:defroute
|
|
,name ,options ,params
|
|
(setf (hunchentoot:content-type*) "image/svg+xml")
|
|
(let ((,response (progn ,@body)))
|
|
(if (stringp ,response) (gv:string->svg ,response) ""))))))
|