Reorganize files

.gitignore

@@ -1 +1,2 @@
 *~
+ywatds

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)'

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))))

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))))

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)))))

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")