From 04f42be1dc2d3ec3ae518f7c892b757047048419 Mon Sep 17 00:00:00 2001 From: y5nw Date: Thu, 12 Aug 2021 22:37:49 +0200 Subject: [PATCH] Reorganize files --- .gitignore | 1 + Makefile | 9 +++ dataserver.lisp | 145 ++++++++++---------------------------------- serialize-lib.lisp | 63 +++++++++++++++++++ server-wrapper.lisp | 40 ++++++++++++ ywatds.asd | 15 +++++ 6 files changed, 160 insertions(+), 113 deletions(-) create mode 100644 Makefile create mode 100644 serialize-lib.lisp create mode 100644 server-wrapper.lisp create mode 100644 ywatds.asd diff --git a/.gitignore b/.gitignore index b25c15b..b3289bd 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ *~ +ywatds diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d8cbfc9 --- /dev/null +++ b/Makefile @@ -0,0 +1,9 @@ +LISP ?= sbcl + +# https://lispcookbook.github.io/cl-cookbook/scripting.html +build: + $(LISP) --eval '(require :asdf)' \ + --eval '(load "ywatds.asd")' \ + --eval '(asdf:load-system "ywatds")' \ + --eval '(asdf:make :ywatds)' \ + --eval '(quit)' diff --git a/dataserver.lisp b/dataserver.lisp index 126c13b..5d47df6 100644 --- a/dataserver.lisp +++ b/dataserver.lisp @@ -1,117 +1,36 @@ -(require "asdf") -(asdf:load-system :easy-routes) -(asdf:load-system :cl-ppcre) -(asdf:load-system :parse-float) -(use-package :parse-float) +(defpackage :ywatds + (:use :cl) + (:export :program-entry)) +(in-package :ywatds) -(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) +(defun program-entry () + (let* ((argv (uiop:command-line-arguments)) + (worldpath (uiop:ensure-pathname (car argv) + :defaults (uiop:getcwd) + :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") + :defaults (uiop:getcwd) :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)) + (serverport (parse-integer (cadr argv))) + (server (make-instance 'easy-routes:easy-routes-acceptor + :port serverport))) + (setf (hunchentoot:acceptor-document-root server) wwwpath) + (ywsw:safe-text-route + ("/dumpser/:p" :method :get) (&path (p 'string)) + (format nil "~s" + (atsl:from-file + (uiop:subpathname worldpath (format nil "advtrains_~a" p)) + 'alist))) + (hunchentoot:start server) + ;; loop until an error occurs + (handler-case (loop (sleep most-positive-fixnum)) + (t (c) (format t "~&~a~%" c))) + (ignore-errors + (hunchentoot:stop server) + (uiop:quit)))) diff --git a/serialize-lib.lisp b/serialize-lib.lisp new file mode 100644 index 0000000..a774133 --- /dev/null +++ b/serialize-lib.lisp @@ -0,0 +1,63 @@ +(defpackage :advtrains-serialize-lib + (:use :cl :parse-float) + (:nicknames :atsl) + (:export :from-file :from-stream)) +(in-package :atsl) + +(defmacro 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 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 (unescape ,restdata)))))) + +(defmacro adjust-line (line) + `(string-right-trim '(#\Return) ,line)) + +(defun read-table (stream restype) + (let ((ht (case restype + ('alist nil) + (otherwise (make-hash-table))))) + (do ((line (adjust-line (read-line stream nil)) + (adjust-line (read-line stream nil)))) + ((or (null line) (equal line "E")) ht) + (cl-ppcre:register-groups-bind + (key value) + ("^(.*[^&]):(.+)$" line) + (let* ((kv (string-to-value key nil)) + (vt (string-to-value value t)) + (vv (if (equal vt 'table) + (read-table stream restype) + vt))) + (case restype + ('alist (push (cons kv vv) ht)) + (otherwise (setf (gethash kv ht) vv)))))))) + +(defun from-stream (stream restype) + (let* ((header (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) + (read-table stream restype))) + +(defmacro from-file (fn restype) + (let ((stream (gensym))) + `(with-open-file (,stream ,fn) + (from-stream ,stream ,restype)))) diff --git a/server-wrapper.lisp b/server-wrapper.lisp new file mode 100644 index 0000000..b7586c5 --- /dev/null +++ b/server-wrapper.lisp @@ -0,0 +1,40 @@ +(defpackage :ywatds-server-wrapper + (:use :cl) + (:nicknames :ywsw) + (:export :toxml :safe-text-route)) +(in-package :ywsw) + +(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) + (let ((c (gensym))) + `(handler-case (progn ,@body) + (t (,c) + (setf (hunchentoot:return-code*) 403) + (hunchentoot:log-message* :error (format nil "~a" ,c)) + 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))))) diff --git a/ywatds.asd b/ywatds.asd new file mode 100644 index 0000000..e0108cb --- /dev/null +++ b/ywatds.asd @@ -0,0 +1,15 @@ +(in-package :asdf-user) +(defsystem "ywatds" + :description "ywatds: simple server that pulls data from advtrains savefiles" + :version "0.1" + :author "Y.W." + :license "GNU AGPL 3 or later" + :depends-on ("asdf" "easy-routes" "cl-ppcre" "parse-float") + :components ((:file "serialize-lib") + (:file "server-wrapper") + (:file "dataserver" :depends-on ("serialize-lib" + "server-wrapper"))) + ;; https://lispcookbook.github.io/cl-cookbook/scripting.html + :build-operation "program-op" + :build-pathname "ywatds" + :entry-point "ywatds:program-entry")