2023-08-06 23:25:20 +00:00
# !/usr/bin/env -S sbcl --script
( load "~/.local/share/common-lisp/quicklisp/setup.lisp" )
( ql:quickload "uiop" )
( ql:quickload "bordeaux-threads" )
( ql:quickload "usocket" )
( defconstant *unix-epoch-offset*
( encode-universal-time 0 0 0 1 1 1970 0 ) )
2023-08-08 05:31:09 +00:00
( defconstant *current-millennium-AD* 2000 )
( defun universal-to-unix-time ( universal-time )
2023-08-06 23:25:20 +00:00
( - universal-time *unix-epoch-offset* )
)
( defun get-unix-time ( )
( universal-to-unix-time ( get-universal-time ) )
)
2023-08-08 05:31:09 +00:00
( defun unix-to-universal-time ( unix-time )
( + unix-time *unix-epoch-offset* )
)
( defun unix-to-timedate ( unix-time )
( multiple-value-bind ( seconds minutes hours day month year ) ( decode-universal-time ( unix-to-universal-time unix-time ) )
2023-08-09 03:33:21 +00:00
( format nil "~D/~D/~D--~D:~D.~D" month day ( - year *current-millennium-AD* ) hours minutes seconds ) )
2023-08-08 05:31:09 +00:00
)
2023-08-06 23:25:20 +00:00
( defun err ( errno &optional str )
( case errno
( 1 ( format t "lsmd: Failed to open configuration file: ~A. Do I have correct permissions?" str ) )
) ;some other possible errs:
;failed to bind to socket
;invalid/illegal config
;
( sb-ext:exit :code errno )
)
( defun neterr ( errno &optional command args )
( concatenate 'string ( write-to-string errno ) "@"
( case errno
( 11 ( format nil "Unrecognized command ~A:~A" command args ) )
( 12 ( format nil "Cannot ~A the program ~A (not defined in configuration)" command args ) )
( 13 ( format nil "Process ~A failed to start." command ) )
( 14 ( format nil "Cannot ~A the program ~A (not in configuration)" command args ) )
( 15 ( format nil "Cannot stop the program ~A (not in environment)" args ) )
( 16 ( format nil "Cannot start the program ~A (program already running)" args ) )
( 17 ( format nil "Cannot stop the program ~A (program not started)" args ) )
2023-08-07 00:08:19 +00:00
( 99 ( format nil "Unknown error" ) )
2023-08-06 23:25:20 +00:00
) )
)
( defun cfg-buildline ( pline nline )
( if nline
;TODO: Proper validation of config values here. Err if bad
; this should be a proper wrapper and not just 2 lines.
( append pline nline ) )
)
( defun select-db ( db label value )
( car ( remove-if-not #' ( lambda ( dbline ) ( equal ( getf dbline label ) value ) ) db ) )
)
( defun select-dbp ( db progr label )
( getf ( select-db db :prog progr ) label )
)
( defun delete-db ( db label value )
( remove-if #' ( lambda ( dbline ) ( equal ( getf dbline label ) value ) ) db )
)
( defun configure ( file )
( let ( ( cfgfile ( open file :if-does-not-exist nil ) ) )
( cond ( ( not cfgfile )
( return-from configure ( err 1 file ) ) ) )
( loop with progline with progs
do ( multiple-value-bind ( line eof ) ( read-line cfgfile nil )
( cond
( eof ;TODO: Allowances for whitespace in config here
( push progline progs )
( close cfgfile )
( return-from configure progs ) )
( ( eq ( char line 0 ) #\[ )
( cond ( progline
( push progline progs ) ) )
( setq progline ( cfg-buildline NIL ( list :prog ( subseq line 1 ( position #\] line :test #' equal ) ) ) ) ) )
( t
( let ( ( setting ( uiop:split-string line :separator "=" ) ) )
( setq progline ( cfg-buildline progline ( list ( intern ( string-upcase ( car setting ) ) "KEYWORD" )
( car ( last setting ) ) ) ) ) ) ) ) ) ) ) ;TODO: A more efficient way than breaking the string down and making it again?
)
( defun start ( progs env progr &optional automatic )
( let ( ( progline ( select-db progs :prog progr ) )
( envline ( select-db env :prog progr ) ) )
( cond ( ( not progline )
( return-from start ( neterr 12 "start" progr ) ) )
( envline
( cond ( ( uiop:process-alive-p ( getf envline :nfo ) )
2023-08-10 19:42:59 +00:00
( return-from start ( values ( neterr 16 "start" progr ) env ) ) )
2023-08-06 23:25:20 +00:00
( t
( setf env ( delete-db env :prog progr ) ) ) ) ) )
( loop for req in ( uiop:split-string ( getf progline :require ) )
do ( let ( ( nfo ( select-dbp env req :nfo ) ) )
( cond ( nfo
( cond ( ( uiop:process-alive-p nfo )
nil )
( t
2023-08-07 00:08:19 +00:00
( multiple-value-bind ( rets nenv ) ( start progs env req )
( cond ( ( not ( string= "0" rets ) )
( return-from start rets ) ) )
( setf env nenv ) ) ) ) )
2023-08-06 23:25:20 +00:00
( t
2023-08-07 00:08:19 +00:00
( multiple-value-bind ( rets nenv ) ( start progs env req )
( cond ( ( not ( string= "0" rets ) )
( return-from start rets ) ) )
( setf env nenv ) ) ) ) ) )
2023-08-06 23:25:20 +00:00
( let ( ( nfo ( uiop:launch-program ( getf progline :start )
:error-output ( or ( getf progline :stderr ) ( concatenate 'string ( uiop:getenv "HOME" ) "/.var/log/" progr ".log" ) )
:if-error-output-exists :append
:directory ( select-dbp progs progr :dir ) ) ) )
( bt:make-thread
( lambda ( )
( let ( ( exit-code ( uiop:wait-process nfo ) ) )
( cond ( ( and ( plusp exit-code ) ( not automatic ) )
( start progs env progr t ) ) ) ) ;TODO: Mark & notify user when auto restart fails, rather than doing nothing. Maybe a config option?
)
:name ( concatenate 'string progr "on lsm" ) )
( cond ( ( getf progline :secs )
2023-08-09 03:33:21 +00:00
( sleep ( parse-integer * ) ) ;Should work here I think. also remember to do config checking rather than parsing the int here.
2023-08-06 23:25:20 +00:00
( cond ( ( plusp ( slot-value nfo 'uiop/launch-program::exit-code ) )
2023-08-10 19:42:59 +00:00
( return-from start ( values ( neterr 13 progr ) env ) ) ) ) ) ) ;TODO: Turn this into an AND or something cuz it's ugly
2023-08-06 23:25:20 +00:00
( values "0" ( push ( list :prog progr :nfo nfo :time ( get-unix-time ) :ll 0 ) env ) ) ) )
)
( defun stop ( progs env progr )
( let ( ( progline ( select-db progs :prog progr ) )
( nfo ( select-dbp env progr :nfo ) ) )
2023-08-10 19:42:59 +00:00
2023-08-06 23:25:20 +00:00
( cond ( ( not progline )
( return-from stop ( neterr 14 "stop" progr ) ) )
( ( not nfo )
( return-from stop ( neterr 15 "stop" progr ) ) )
( ( not ( uiop:process-alive-p nfo ) )
( return-from stop ( neterr 17 "stop" progr ) ) ) ) ;TODO: make this only send progr [keywords maybe?] - also, might want better control flow here.
2023-08-10 19:42:59 +00:00
2023-08-06 23:25:20 +00:00
( let ( ( stop ( select-dbp progs progr :stop ) ) )
( cond ( stop
( uiop:run-program stop ) )
( t
( uiop:run-program ( format nil "pkill -P ~D" ( uiop:process-info-pid nfo ) ) ) ) ) ) ) ;TODO: add killsecs attribute. Try kill with SIGTERM & if killsecs not met, then use SIGKILL.
;Also need an if here that runs stop script rather than killing if specified.
"0"
)
( defun statusline ( progline env &optional notime )
( handler-case ;TODO: I don't really need the error handler, can just do (cond nfo) and then try to read slot.
( let* ( ( envline ( select-db env :prog ( getf progline :prog ) ) )
( nfo ( getf envline :nfo ) )
( alive ( uiop:process-alive-p nfo ) ) )
2023-08-08 05:31:09 +00:00
( let ( ( esc ( code-char 27 ) ) )
( concatenate 'string
( cond ( alive
( format nil "~C[92mrunning~C[0m" esc esc ) )
( t ( let ( ( exitcode ( slot-value nfo 'uiop/launch-program::exit-code ) ) )
( cond ( ( plusp exitcode )
( format nil "~C[31mdead~C[0m" esc esc ) )
( ( zerop exitcode )
( format nil "~C[32mfinished~C[0m" esc esc ) )
( t "not started" ) ) ) ) )
2023-08-09 03:33:21 +00:00
( let ( ( launchtime ( getf envline :time ) )
( timeformat ( getf progline :time ) ) )
2023-08-08 05:31:09 +00:00
( cond ( ( and ( not notime ) launchtime )
2023-08-09 03:33:21 +00:00
( format nil "; started at ~D" ( cond ( ( string= "unix" timeformat )
( launchtime ) )
( t
( unix-to-timedate launchtime ) ) ) ) )
2023-08-08 05:31:09 +00:00
( t nil ) ) ) ) ) )
( sb-pcl::missing-slot ( c ) "not started" ) )
2023-08-06 23:25:20 +00:00
)
( defun status ( progs env &optional progr )
( cond ( ( > ( length progr ) 0 )
( let ( ( progline ( select-db progs :prog progr ) ) )
( cond ( ( not progline )
( return-from status ( neterr 12 "status" progr ) ) ) )
( concatenate 'string
( handler-case
2023-08-08 05:31:09 +00:00
( format nil "0@\~A:~%~Cstatus: ~A~%~Cstart: ~A~%~Cprocess: ~D~%~%" progr #\tab ( statusline progline env ) #\tab ( getf progline :start ) #\tab ( uiop:process-info-pid ( select-dbp env progr :nfo ) ) )
( sb-pcl::missing-slot ( c ) ( format nil "0@\~A:~%~Cstatus: ~A~%~Cstart: ~A~%~Cprocess: NIL~%~%" progr #\tab ( statusline progline env ) #\tab ( getf progline :start ) #\tab ) ) )
2023-08-06 23:25:20 +00:00
( let ( ( output ( make-string-output-stream ) ) )
( uiop:run-program ( format nil "tail -n 5 ~A" ( or ( getf progline :stderr ) ( concatenate 'string ( uiop:getenv "HOME" ) "/.var/log/" progr ".log" ) ) ) :output output ) ;TODO: unsafe
( get-output-stream-string output ) ) ) )
)
( t
( let ( ( globalstatus "0@" ) )
2023-08-08 05:31:09 +00:00
( loop for progline in ( delete-db progs :prog "lsm" )
do ( let ( ( progr ( getf progline :prog ) )
( status ( statusline progline env t ) ) )
( setq globalstatus ( concatenate 'string globalstatus
2023-08-09 03:33:21 +00:00
( format nil "~A:~A~C~A~C~%"
2023-08-08 05:31:09 +00:00
progr
( format nil "~v{~a~:*~}" ( - 79 ( + ( + ( length progr ) 1 ) ( + ( length status )
( cond ( ( find #\m status )
-7 )
( t 2 ) )
) ) ) ' ( #\space ) )
#\[
status
#\] ) ) ) ) )
globalstatus ) ) )
2023-08-06 23:25:20 +00:00
)
2023-08-08 05:31:09 +00:00
( defun run_command ( command &optional args &key progs env ) ;TODO: Shutdown all command to exit session gracefully
2023-08-06 23:25:20 +00:00
( cond ( ( string= command "start" )
( start progs env args ) )
( ( string= command "stop" )
( values ( stop progs env args ) env ) )
( ( string= command "restart" )
( stop progs env args )
( start progs env args ) )
( ( string= command "status" )
( values ( status progs env args ) env ) )
( t ( neterr 11 command args ) ) )
)
( defun str-cmd ( str )
( let ( ( strl ( uiop:split-string str :separator " " ) ) )
( values ( pop strl ) ( pop strl ) ) )
)
( defun handle-request ( stream progs env )
( let ( ( line ( read-line stream ) ) )
( multiple-value-bind ( rets nenv ) ( multiple-value-call #' run_command ( str-cmd line ) :progs progs :env env )
( format stream "~a" rets )
( terpri stream )
( force-output stream )
nenv ) )
)
;TODO: finish calling command evaluator NOTE: now this changed, what about sanitizing and error-checking input?
( defun server_listen ( addr port progs env )
( let ( ( socket ( usocket:socket-listen addr port :reuse-address t ) ) )
( usocket:wait-for-input socket )
( let ( ( stream ( usocket:socket-stream ( usocket:socket-accept socket ) ) ) )
( let ( ( nenv ( handle-request stream progs env ) ) )
( close stream )
( usocket:socket-close socket )
nenv ) ) )
)
( defun run ( )
( let ( ( cfgloc )
( args ( uiop:command-line-arguments ) ) )
( if args
( setq cfgloc ( pop args ) )
( setq cfgloc ( concatenate 'string ( uiop:getenv "HOME" ) "/.config/lsmrc" ) ) )
( loop with progs = ( configure cfgloc ) with env
do ( setf env ( server_listen ( select-dbp progs "lsm" :addr ) ( parse-integer ( select-dbp progs "lsm" :port ) ) progs env ) ) ) )
)
( run )