2021-08-12 13:37:49 -07:00
( defpackage :ywatds
( :use :cl )
( :export :program-entry ) )
( in-package :ywatds )
2021-08-17 13:57:47 -07:00
( defparameter *ildb* nil )
2021-08-21 11:51:11 -07:00
( defparameter *nodedb* nil )
( defparameter *trackdb* nil )
2021-08-17 13:57:47 -07:00
2021-08-12 13:37:49 -07:00
( 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 ) )
( serverport ( parse-integer ( cadr argv ) ) )
2021-08-21 11:51:11 -07:00
( debugp ( member "--debug" ( cddr argv ) :test #' string= ) )
2021-08-12 14:38:14 -07:00
( server ( make-instance 'easy-routes:routes-acceptor
2021-08-12 13:37:49 -07:00
:port serverport ) ) )
2021-08-14 08:15:42 -07:00
( macrolet ( ( savefilepath ( n )
2021-08-17 13:57:47 -07:00
` ( uiop:subpathname worldpath ( format nil "advtrains_~a" , n ) ) )
( load-data ( )
` ( progn
2021-08-20 06:56:30 -07:00
( setf *ildb* ( atil:import-data ( savefilepath "interlocking.ls" ) ) )
2021-08-21 11:51:11 -07:00
( setf *nodedb* ( ndb:import-data ( savefilepath "ndb4.ls" ) ) )
( setf *trackdb* ( tracks:import-data *nodedb* ) )
( if ( not debugp ) ( setf *nodedb* nil ) )
2021-08-20 06:56:30 -07:00
( hunchentoot:acceptor-log-message server :info "Database updated" ) ) ) )
2021-08-14 08:15:42 -07:00
( ywsw:safe-text-route
2021-08-18 08:11:46 -07:00
dumpser
2021-08-14 08:15:42 -07:00
( "/dumpser/:p" :method :get ) ( &path ( p 'string ) )
2021-08-18 08:11:46 -07:00
( "Deserialize <code>advtrains_<i>p</i></code> into a possibly nested associated list and return the result" )
2021-08-14 08:15:42 -07:00
( format nil "~s" ( atsl:from-file ( savefilepath p ) :alist ) ) )
( ywsw:safe-text-route
2021-08-18 08:11:46 -07:00
pretty-dump-interlocking
2021-08-14 08:15:42 -07:00
( "/pretty_dump/interlocking" :method :get ) ( )
2021-08-18 08:11:46 -07:00
( "Return the interlocking database that is in use" )
2021-08-17 13:57:47 -07:00
( format nil "~s" *ildb* ) )
2021-08-21 11:51:11 -07:00
( 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 ) )
2021-08-17 13:57:47 -07:00
( ywsw:safe-json-route
2021-08-18 08:11:46 -07:00
tcbinfo
( "/tcbinfo" :method :get ) ( )
( "Return a list of TCBs and associated information" )
*ildb* )
( ywsw:safe-json-route
tcbinfo-pos
2021-08-17 13:57:47 -07:00
( "/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 ) )
2021-08-18 08:11:46 -07:00
( "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." )
2021-08-17 13:57:47 -07:00
( 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 ) ) ) ) )
2021-08-21 04:04:22 -07:00
( ywsw:safe-graphviz-route
graph-ilroutes ( "/graph/ilroutes" :method :get ) ( )
( "Return a simple graph of TCBs and available routes" )
( format nil "digraph{~{\"~a\"->\"~a\";~}}"
( 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 ) ) ) ) ) )
2021-08-21 11:51:11 -07:00
( ywsw:safe-graphviz-route
graph-tracks ( "/graph/tracks" :method :get ) ( )
( "Return a simple graph of tracks" )
( tracks:gvdump *trackdb* ) )
2021-08-21 04:04:22 -07:00
( ywsw:defsafe
2021-08-18 08:11:46 -07:00
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 ) ) ) ) ) ) )
2021-08-21 11:51:11 -07:00
( tracks:init-tracks )
2021-08-14 08:15:42 -07:00
( hunchentoot:start server )
2021-08-18 08:11:46 -07:00
( hunchentoot:acceptor-log-message server :info "~s"
( with-output-to-string ( s )
( describe easy-routes:*routes-mapper* s ) ) )
2021-08-14 08:15:42 -07:00
;; loop until an error occurs
2021-08-17 13:57:47 -07:00
( handler-case ( loop do
( load-data )
( sleep 20 ) )
2021-08-21 11:51:11 -07:00
( t ( c )
( format t "~&~a~%" c )
( when debugp ( uiop:handle-fatal-condition c ) ) ) )
2021-08-14 08:15:42 -07:00
( ignore-errors
( hunchentoot:stop server )
( uiop:quit ) ) ) ) )