ywatds/dataserver.lisp

(require "asdf")
(asdf:load-system :easy-routes)
(asdf:load-system :cl-ppcre)
(asdf:load-system :parse-float)
(use-package :parse-float)

(defmacro ser-unescape (seq)
  (let ((match (gensym)) (replacef (gensym)))
    `(flet ((,replacef (,match)
	      (string (ecase (char ,match 1)
			(#\: #\:)
			(#\n #\Newline)
			(#\r #\Return)
			(#\& #\&)))))
       (cl-ppcre:regex-replace-all "&[:nr&]" ,seq #',replacef :simple-calls t))))

(defmacro ser-string-to-value (seq table-allow)
  (let ((str (gensym)) (datatype (gensym)) (restdata (gensym)))
    `(let* ((,str ,seq)
	    (,datatype (char ,str 0))
	    (,restdata (subseq ,str 1)))
       (ecase ,datatype
	 (#\T (if ,table-allow 'table (error "table not allowed")))
	 (#\N (parse-float ,restdata))
	 (#\B (ecase (parse-integer ,restdata)
		(0 t)
		(1 nil)))
	 (#\S (ser-unescape ,restdata))))))

(defmacro ser-adjust-line (line)
  `(string-right-trim '(#\Return) ,line))

(defun ser-read-table (stream restype)
  (let ((ht (case restype
	      ('alist nil)
	      (otherwise (make-hash-table)))))
    (do ((line (ser-adjust-line (read-line stream nil))
	       (ser-adjust-line (read-line stream nil))))
	((or (null line) (equal line "E")) ht)
      (cl-ppcre:register-groups-bind
       (key value)
       ("^(.*[^&]):(.+)$" line)
       (let* ((kv (ser-string-to-value key nil))
	      (vt (ser-string-to-value value t))
	      (vv (if (equal vt 'table)
		      (ser-read-table stream restype)
		      vt)))
	 (case restype
	   ('alist (push (cons kv vv) ht))
	   (otherwise (setf (gethash kv ht) vv))))))))

(defun ser-read-stream (stream restype)
  (let* ((header (ser-adjust-line (read-line stream nil)))
	 (sver (parse-integer
		(cl-ppcre:regex-replace "^LUA_SER v=([12])$" header "\\1"))))
    ;; We don't need much checking here for now
    (assert sver)
    (ser-read-table stream restype)))

(defmacro ser-read-file (fn restype)
  (let ((stream (gensym)))
    `(with-open-file (,stream ,fn)
       (ser-read-stream ,stream ,restype))))

(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 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)
  `(handler-case (progn ,@body)
     (t () (setf (hunchentoot:return-code*) 403) nil)))

(defmacro safe-text-route (options params &body body)
  (let ((name (gensym)) (response (gensym)))
    `(easy-routes:defroute ,name ,options ,params
       (setf (hunchentoot:content-type*) "text/plain")
       (let ((,response (safe-route ,@body)))
	 (if (stringp ,response) ,response nil)))))

(let* ((argv (uiop:command-line-arguments))
       (worldpath (uiop:ensure-pathname (car argv)
					:ensure-directory t
					:want-existing t
					:ensure-absolute t))
       (scriptpath (uiop:ensure-pathname *load-truename*))
       (scriptdir (uiop:pathname-directory-pathname scriptpath))
       (wwwpath (uiop:ensure-pathname (uiop:subpathname scriptdir "www")
				      :ensure-directory t
				      :want-existing t
				      :ensure-absolute t))
       (serverport (parse-integer (cadr argv)))
       (server (make-instance 'easy-routes:easy-routes-acceptor
			      :port serverport)))
  (setf (hunchentoot:acceptor-document-root server) wwwpath)
  (safe-text-route
   ("/dumpser/:p" :method :get) ()
   (format nil "~s"
	   (ser-read-file
	    (uiop:subpathname worldpath (format nil "advtrains_~a" p))
	    'alist)))
  (hunchentoot:start server))