Reorganize files
parent
5dbb96256d
commit
04f42be1dc
|
@ -1 +1,2 @@
|
||||||
*~
|
*~
|
||||||
|
ywatds
|
||||||
|
|
|
@ -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)'
|
145
dataserver.lisp
145
dataserver.lisp
|
@ -1,117 +1,36 @@
|
||||||
(require "asdf")
|
(defpackage :ywatds
|
||||||
(asdf:load-system :easy-routes)
|
(:use :cl)
|
||||||
(asdf:load-system :cl-ppcre)
|
(:export :program-entry))
|
||||||
(asdf:load-system :parse-float)
|
(in-package :ywatds)
|
||||||
(use-package :parse-float)
|
|
||||||
|
|
||||||
(defmacro ser-unescape (seq)
|
(defun program-entry ()
|
||||||
(let ((match (gensym)) (replacef (gensym)))
|
(let* ((argv (uiop:command-line-arguments))
|
||||||
`(flet ((,replacef (,match)
|
(worldpath (uiop:ensure-pathname (car argv)
|
||||||
(string (ecase (char ,match 1)
|
:defaults (uiop:getcwd)
|
||||||
(#\: #\:)
|
:ensure-directory t
|
||||||
(#\n #\Newline)
|
:want-existing t
|
||||||
(#\r #\Return)
|
:ensure-absolute t))
|
||||||
(#\& #\&)))))
|
(scriptpath (uiop:ensure-pathname *load-truename*))
|
||||||
(cl-ppcre:regex-replace-all "&[:nr&]" ,seq #',replacef :simple-calls t))))
|
(scriptdir (uiop:pathname-directory-pathname scriptpath))
|
||||||
|
(wwwpath (uiop:ensure-pathname (uiop:subpathname scriptdir "www")
|
||||||
(defmacro ser-string-to-value (seq table-allow)
|
:defaults (uiop:getcwd)
|
||||||
(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
|
:ensure-directory t
|
||||||
:want-existing t
|
:want-existing t
|
||||||
:ensure-absolute t))
|
:ensure-absolute t))
|
||||||
(scriptpath (uiop:ensure-pathname *load-truename*))
|
(serverport (parse-integer (cadr argv)))
|
||||||
(scriptdir (uiop:pathname-directory-pathname scriptpath))
|
(server (make-instance 'easy-routes:easy-routes-acceptor
|
||||||
(wwwpath (uiop:ensure-pathname (uiop:subpathname scriptdir "www")
|
:port serverport)))
|
||||||
:ensure-directory t
|
(setf (hunchentoot:acceptor-document-root server) wwwpath)
|
||||||
:want-existing t
|
(ywsw:safe-text-route
|
||||||
:ensure-absolute t))
|
("/dumpser/:p" :method :get) (&path (p 'string))
|
||||||
(serverport (parse-integer (cadr argv)))
|
(format nil "~s"
|
||||||
(server (make-instance 'easy-routes:easy-routes-acceptor
|
(atsl:from-file
|
||||||
:port serverport)))
|
(uiop:subpathname worldpath (format nil "advtrains_~a" p))
|
||||||
(setf (hunchentoot:acceptor-document-root server) wwwpath)
|
'alist)))
|
||||||
(safe-text-route
|
(hunchentoot:start server)
|
||||||
("/dumpser/:p" :method :get) ()
|
;; loop until an error occurs
|
||||||
(format nil "~s"
|
(handler-case (loop (sleep most-positive-fixnum))
|
||||||
(ser-read-file
|
(t (c) (format t "~&~a~%" c)))
|
||||||
(uiop:subpathname worldpath (format nil "advtrains_~a" p))
|
(ignore-errors
|
||||||
'alist)))
|
(hunchentoot:stop server)
|
||||||
(hunchentoot:start server))
|
(uiop:quit))))
|
||||||
|
|
|
@ -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))))
|
|
@ -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)))))
|
|
@ -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")
|
Loading…
Reference in New Issue