2021-08-12 13:37:49 -07:00
( defpackage :ywatds
( :use :cl )
( :export :program-entry ) )
( in-package :ywatds )
2021-08-22 13:24:54 -07:00
;; Databases
2021-08-17 13:57:47 -07:00
( defparameter *ildb* nil )
2021-08-21 11:51:11 -07:00
( defparameter *trackdb* nil )
2021-08-17 13:57:47 -07:00
2021-08-22 13:24:54 -07:00
;; Command-line arguments
( defparameter *debugp* nil )
2021-08-23 08:33:33 -07:00
( defparameter *gcp* nil )
2021-08-22 13:24:54 -07:00
( defparameter *world-path* nil )
;; Note: do NOT change *server-port* and *server* at debug time
( defparameter *server-port* nil )
( defparameter *server* nil )
2021-08-25 03:46:24 -07:00
#+ sbcl ( declaim ( sb-ext:always-bound *ildb* *trackdb*
*debugp* *gcp* *world-path* *server-port* *server* ) )
2021-08-22 13:24:54 -07:00
( defmacro ensure-world-path ( path )
` ( uiop:ensure-pathname , path :defaults ( uiop:getcwd ) :ensure-directory t
:want-existing t :ensure-absolute t ) )
( defmacro savefilepath ( name )
2021-08-25 03:46:24 -07:00
` ( uiop:subpathname *world-path* , ( if ( stringp name )
( concatenate 'string "advtrains_" name )
` ( concatenate 'string "advtrains_" , name ) ) ) )
2021-08-22 13:24:54 -07:00
2021-08-23 14:49:46 -07:00
( defun load-data ( )
2021-08-25 03:46:24 -07:00
( let* ( ( ildb ( atil:load-ildb ( savefilepath "interlocking.ls" ) ) )
( tdb ( tracks:load-trackdb ( savefilepath "ndb4.ls" ) ) ) )
( psetf *ildb* ildb *trackdb* tdb )
( when *gcp*
#+ sbcl ( sb-ext:gc :full t ) )
( hunchentoot:acceptor-log-message *server* :info "Database updated" ) ) )
2021-08-22 13:24:54 -07:00
( defmacro mainloop ( )
` ( loop ( load-data ) ( sleep 20 ) ) )
2021-08-12 13:37:49 -07:00
( defun program-entry ( )
2021-08-22 13:24:54 -07:00
( let ( ( argv ( uiop:command-line-arguments ) ) )
( setf *world-path* ( ensure-world-path ( car argv ) ) )
( setf *server-port* ( coerce ( parse-integer ( cadr argv ) ) ' ( integer 0 65535 ) ) )
( setf *debugp* ( member "--debug" ( cddr argv ) :test #' string= ) )
2021-08-23 08:33:33 -07:00
( setf *gcp* ( member "--force-periodic-gc" ( cddr argv ) :test #' string= ) )
2021-08-22 13:24:54 -07:00
( setf *server* ( make-instance 'easy-routes:routes-acceptor :port *server-port* ) )
( register-routes )
( register-debugging-routes )
( start-server ) ) )
( defun register-routes ( )
( ywsw:safe-text-route
dumpser
( "/dumpser/:p" :method :get ) ( &path ( p 'string ) )
( "Deserialize <code>advtrains_<i>p</i></code> into a possibly nested associated list and return the result" )
( format nil "~s" ( atsl:from-file ( savefilepath p ) :alist ) ) )
( ywsw:safe-text-route
pretty-dump-interlocking
( "/pretty-dump/interlocking" :method :get ) ( )
( "Return the interlocking database that is in use" )
( format nil "~s" *ildb* ) )
( ywsw:safe-text-route
pretty-dump-registered-tracks
( "/pretty-dump/registered-tracks" :method :get ) ( )
( "Return the list of tracks known to the server" )
( tracks:dump-track-definitions ) )
( ywsw:safe-json-route
tcbinfo
( "/tcbinfo" :method :get ) ( )
( "Return a list of TCBs and associated information" )
*ildb* )
( ywsw:safe-json-route
tcbinfo-pos
( "/tcbinfo/:x/:y/:z" :method :get )
( &get
( ln :parameter-type 'string ) ( rc :parameter-type 'string )
( side :parameter-type 'string )
( next :parameter-type 'boolean )
&path ( x 'integer ) ( y 'integer ) ( z 'integer ) )
( "Return information on the TCB assigned to the track at (<i>x</i>,<i>y</i>,<i>z</i>). If <i>side</i> is provided, return only information related to side <i>side</i> of the TCB. If <i>ln</i> and/or <i>rc</i> is provided in addition to <i>side</i>, return the first route with ARS rule(s) matching the line <i>ln</i> or routing code <i>rc</i>. If <i>next</i> is specified in addition to <i>side</i> and any of <i>ln</i> and <i>rc</i>, return where the route ends." )
( if ( and x y z )
( let ( ( tcb ( atil:find-tcb-at *ildb* ( aux:make-v3d :x x :y y :z z ) ) ) )
( cond
( ( not tcb ) nil )
( side
( let ( ( tcbs ( cond
( ( string-equal side "a" ) ( atil:tcb-side-a tcb ) )
( ( string-equal side "b" ) ( atil:tcb-side-b tcb ) )
( t nil ) ) ) )
( cond
( ( not tcbs ) nil )
( ( or ln rc )
( let ( ( route ( atil:match-route ( atil:tcbdata-routes tcbs )
( or ln "" ) ( or rc "" ) ) ) )
( cond
( ( not route ) nil )
( next ( atil:route-next route ) )
( t route ) ) ) )
( t tcbs ) ) ) )
( t tcb ) ) ) ) )
( ywsw:safe-graphviz-route
graph-ilroutes ( "/graph/ilroutes" :method :get ) ( )
( "Return a simple graph of TCBs and available routes" )
2021-08-23 09:04:00 -07:00
( format nil "digraph{~%~{\"~a\"->\"~a\";~%~}}"
2021-08-22 13:24:54 -07:00
( loop for pos being the hash-keys of ( atil:ildb-tcbs *ildb* )
using ( hash-value tcb )
append ( loop with side = ( atil:make-tcbside :pos pos :side 0 )
for i across ( atil:tcbdata-routes ( atil:tcb-side-a tcb ) )
append ( list side ( atil:route-next i ) ) )
append ( loop with side = ( atil:make-tcbside :pos pos :side 1 )
for i across ( atil:tcbdata-routes ( atil:tcb-side-b tcb ) )
append ( list side ( atil:route-next i ) ) ) ) ) )
( ywsw:safe-graphviz-route
graph-tracks ( "/graph/paths" :method :get ) ( )
( "Return a simple graph of paths" )
( tracks:gvdump *trackdb* ) )
2021-08-23 05:50:20 -07:00
( ywsw:safe-text-route
find-path ( "/find-path/:from-pos/:from-side/:to-pos/:to-side" :method :get )
( &path ( from-pos 'string ) ( from-side 'integer )
( to-pos 'string ) ( to-side 'integer ) )
( "Find path between two entries in the track database" )
( multiple-value-bind ( path dist )
( tracks:dijkstra *trackdb*
( tracks:trackside ( aux:string-to-v3d from-pos ) from-side )
( tracks:trackside ( aux:string-to-v3d to-pos ) to-side ) )
( if path ( format nil "Distance: ~a~%~{~#[~;To~:;From~] ~a~@{~%~#[~;To~:;Via~] ~a~}~}"
dist path )
"No path" ) ) )
2021-08-22 13:24:54 -07:00
( ywsw:defsafe
docroute-master ( "/doc" :method :get ) ( )
( let ( ( entries ( loop for i being the hash-keys of easy-routes::*routes*
for s = ( string-downcase ( string i ) )
when ( string/= ( subseq s 0 3 ) "doc" )
collect s ) ) )
( ywsw:wrap-html
"Documentation"
` ( "h2" ( ) "Documentation" )
` ( "ul" ( ) ,@ ( loop for i in ( stable-sort entries #' string< )
collect ` ( "li" ( ) ( "a" ( "href" , ( format nil "/doc/http-~a" i ) )
, i ) ) ) ) ) ) ) )
( defun register-debugging-routes ( )
( macrolet
( ( debug-routes ( &body body )
` ( progn ,@ ( loop for i in body collect
` ( ywsw:safe-text-route
, ( car i ) , ( cadr i ) , ( caddr i )
, ( cons "<b>[Only available in debugging mode]</b> " ( cadddr i ) )
( if *debugp* ( progn ,@ ( cddddr i ) )
"Debugging mode is disabled. Please run the server with --debug or set ywatds::*debugp* to a non-nil value." ) ) ) ) ) )
( debug-routes
( debug-room ( "/debug/room" :method :get ) ( ) ( "Dumps the output of <code>(room t)</code>" )
( with-output-to-string ( *standard-output* ) ( room t ) ) )
( debug-routes ( "/debug/routes" :method :get ) ( ) ( "List defined routes" )
( with-output-to-string ( s )
( describe easy-routes:*routes-mapper* s ) ) ) ) ) )
( defun start-server ( )
( tracks:init-tracks )
2021-08-23 14:49:46 -07:00
( if *debugp* ( break ) )
2021-08-23 08:33:33 -07:00
( load-data )
2021-08-22 13:24:54 -07:00
( hunchentoot:start *server* )
;; loop until an error occurs
( if *debugp* ( mainloop ) ( handler-case ( mainloop )
( t ( c ) ( format *error-output* "~&~a~%" c ) ) ) )
( ignore-errors
( hunchentoot:stop *server* )
( uiop:quit ) ) )