(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 "&amp;~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) ""))))))