1.1--- a/lisp/bin/skel.lisp Tue May 28 17:55:30 2024 -0400
1.2+++ b/lisp/bin/skel.lisp Tue May 28 23:12:31 2024 -0400
1.3@@ -29,11 +29,13 @@
1.4
1.5 (defcmd skc-init
1.6 (let ((file (when $args (pop $args)))
1.7- (name (if (> $argc 1) (pop $args))))
1.8+ (name (when (> $argc 1) (pop $args)))) ;; TODO: test, may need to be
1.9+ ;; sequential for side-effect
1.10+ ;; of pop
1.11 (handler-bind
1.12- ((sb-ext:file-exists
1.13+ ((sb-ext:file-exists
1.14 #'(lambda (s)
1.15- (uiop:println (format nil "file already exists: ~A" (or file *default-skelfile*)))
1.16+ (std:println (format nil "file already exists: ~A" (or file *default-skelfile*)))
1.17 (let ((f2 (read-line)))
1.18 (if (string= f2 "")
1.19 (error s)
1.20@@ -83,7 +85,6 @@
1.21 (":vc" (sk-vc *skel-project*))
1.22 (":docs" (sk-docs *skel-project*))
1.23 (":scripts" (sk-scripts *skel-project*))
1.24- (":snippets" (sk-snippets *skel-project*))
1.25 (":rules" (sk-rules *skel-project*))
1.26 (":env" (sk-env *skel-project*))
1.27 (":vars" (sk-vars *skel-project*))
1.28@@ -111,7 +112,7 @@
1.29 (defcmd skc-pull
1.30 (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
1.31 (:git (run-git-command "pull" $args t))
1.32- (:hg (run-hg-command "pull" (append "-u" $args) t))
1.33+ (:hg (run-hg-command "pull" (append '("-u") $args) t))
1.34 (t (skel-error "unknown VC type"))))
1.35
1.36 (defun hg-status ()
1.37@@ -162,7 +163,16 @@
1.38 (sk-find-script
1.39 (pathname-name script)
1.40 (find-skelfile #P"." :load t))))) $args)
1.41- (required-argument :script)))
1.42+ (required-argument 'name)))
1.43+
1.44+(defcmd skc-vc
1.45+ (print $args)
1.46+ (print $opts)
1.47+ (print $cli)
1.48+ (if $args
1.49+ (std/string:string-case ((car $args) :default (skel-error "invalid command"))
1.50+ ("status" (skc-status nil nil)))
1.51+ (skc-status nil $opts)))
1.52
1.53 (defcmd skc-shell
1.54 (sb-ext:enable-debugger)
1.55@@ -208,6 +218,11 @@
1.56 (:name "user" :description "print user configuration")
1.57 (:name "system" :description "print system configuration"))
1.58 :thunk skc-show)
1.59+ (:name vc
1.60+ :description "version control"
1.61+ :thunk skc-vc
1.62+ :opts (make-opts
1.63+ (:name "root" :description "repository path" :kind directory)))
1.64 (:name id
1.65 :description "print the project id"
1.66 :thunk skc-id)
2.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2+++ b/lisp/ffi/readline/pkg.lisp Tue May 28 23:12:31 2024 -0400
2.3@@ -0,0 +1,70 @@
2.4+;;; pkg.lisp --- low-level bindings to librustls
2.5+
2.6+;;; Commentary:
2.7+
2.8+;;; Code:
2.9+(defpackage :readline
2.10+ (:use :cl :sb-alien :std/alien)
2.11+ (:export :load-readline))
2.12+
2.13+(in-package :readline)
2.14+
2.15+(define-alien-loader "readline" t "/usr/lib/")
2.16+
2.17+(macrolet ((def-rl-var (name var type)
2.18+ `(define-alien-variable (,name ,var) ,type)))
2.19+ (def-rl-var "rl_line_buffer" *line-buffer* c-string)
2.20+ (def-rl-var "rl_point" *point* int)
2.21+ (def-rl-var "rl_end" *end* int)
2.22+ (def-rl-var "rl_mark" *mark* int)
2.23+ (def-rl-var "rl_done" *point* boolean)
2.24+ (def-rl-var "rl_num_chars_to_read" *num-chars-to-read* int)
2.25+ (def-rl-var "rl_pending_input" *pending-input* int)
2.26+ (def-rl-var "rl_dispatching" *point* boolean)
2.27+ (def-rl-var "rl_erase_empty_line" *point* boolean)
2.28+ (def-rl-var "rl_prompt" *prompt* c-string)
2.29+ (def-rl-var "rl_display_prompt" *display-prompt* c-string)
2.30+ (def-rl-var "rl_already_prompted" *already-prompted* boolean)
2.31+ (def-rl-var "rl_library_version" *library-version* c-string)
2.32+ ;; (def-rl-var "rl_readline_version" *readline-version* version)
2.33+ (def-rl-var "rl_gnu_readline_p" *gnu-readline-p* boolean)
2.34+ (def-rl-var "rl_terminal_name" *terminal-name* c-string)
2.35+ (def-rl-var "rl_readline_name" *readline-name* c-string)
2.36+ (def-rl-var "rl_instream" *instream* (* t))
2.37+ (def-rl-var "rl_outstream" *outstream* (* t))
2.38+ (def-rl-var "rl_prefer_env_winsize" *prefer-env-winsize* boolean)
2.39+ (def-rl-var "rl_last_func" *last-func* (* t))
2.40+ (def-rl-var "rl_startup_hook" *startup-hook* (* t))
2.41+ (def-rl-var "rl_pre_input_hook" *pre-input-hook* (* t))
2.42+ (def-rl-var "rl_event_hook" *event-hook* (* t))
2.43+ (def-rl-var "rl_getc_function" *getc-function* (* t))
2.44+ (def-rl-var "rl_signal_event_hook" *signal-event-hook* (* t))
2.45+ (def-rl-var "rl_input-available_hook" *input-available-hook* (* t))
2.46+ (def-rl-var "rl_redisplay_function" *redisplay-function* (* t))
2.47+ (def-rl-var "rl_prep_term_function" *prep-term-function* (* t))
2.48+ (def-rl-var "rl_deprep_term_function" *deprep-term-function* (* t))
2.49+ (def-rl-var "rl_executing_keymap" *executing-keymap* (* t))
2.50+ (def-rl-var "rl_binding_keymap" *binding-keymap* (* t))
2.51+ (def-rl-var "rl_executing_macro" *executing-macro* c-string)
2.52+ (def-rl-var "rl_executing_key" *executing-key* char)
2.53+ (def-rl-var "rl_executing_keyseq" *executing-keyseq* c-string)
2.54+ (def-rl-var "rl_key_sequence_length" *key-sequence-length* int)
2.55+ ;; (def-rl-var "rl_readline_state" *readline-state* int)
2.56+ (def-rl-var "rl_explicit_arg" *explicit-arg* boolean)
2.57+ (def-rl-var "rl_numeric_arg" *numeric-arg* int)
2.58+ ;; (def-rl-var "rl_editing_mode" *editing-mode* int)
2.59+ (def-rl-var "rl_catch_sigwinch" *catch-sigwinch* boolean)
2.60+ (def-rl-var "rl_change_environment" *change-environment* boolean)
2.61+ (def-rl-var "rl_attempted_completion_function" *attempted-completion-function* (* t))
2.62+ (def-rl-var "rl_completion_display_matches_hook" *completion-display-matches-hook* (* t))
2.63+ (def-rl-var "rl_basic_word_break_characters" *basic-word-break-characters* c-string)
2.64+ (def-rl-var "rl_completer_word_break_character" *completer-word-break-characters* c-string)
2.65+ (def-rl-var "rl_completion_query_items" *completer-query-items* int)
2.66+ (def-rl-var "rl_completion_append_character" *completion-append-character* char)
2.67+ (def-rl-var "rl_ignore_completion_duplicates" *ignore-completion-duplicates* boolean)
2.68+ (def-rl-var "rl_attempted_completion_over" *attempted-completion-over* boolean)
2.69+ (def-rl-var "rl_sort_completion_matches" *sort-completion-matches* boolean)
2.70+ ;; (def-rl-var "rl_completion_type" *completion-type* completion-type)
2.71+ (def-rl-var "rl_inhibit_completion" *inhibit-completion* boolean)
2.72+ (def-rl-var "history_base" *history-base* int)
2.73+ (def-rl-var "history_length" *history-length* int))
3.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2+++ b/lisp/ffi/readline/readline.asd Tue May 28 23:12:31 2024 -0400
3.3@@ -0,0 +1,18 @@
3.4+;;; readline.asd --- GNU Readline FFI bindings
3.5+
3.6+;;
3.7+
3.8+;;; Commentary:
3.9+
3.10+;;
3.11+
3.12+;;; Code:
3.13+(defsystem :readline
3.14+ :depends-on (:std)
3.15+ :components ((:file "pkg"))
3.16+ :in-order-to ((test-op (test-op "readline/tests"))))
3.17+
3.18+(defsystem :readline/tests
3.19+ :depends-on (:rt :readline)
3.20+ :components ((:file "tests"))
3.21+ :perform (test-op (op c) (uiop:symbol-call :rt :do-tests :readline)))
4.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/ffi/readline/readline.lisp Tue May 28 23:12:31 2024 -0400
4.3@@ -0,0 +1,7 @@
4.4+;;; readline/readline.lisp --- Readline Alien Routines
4.5+
4.6+;; also consider https://github.com/antirez/linenoise
4.7+
4.8+;;; Code:
4.9+(in-package :readline)
4.10+
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/ffi/readline/tests.lisp Tue May 28 23:12:31 2024 -0400
5.3@@ -0,0 +1,17 @@
5.4+;;; readline/tests.lisp --- readline tests
5.5+
5.6+;;; Code:
5.7+(defpackage :readline/tests
5.8+ (:use :cl :std :rt :readline))
5.9+
5.10+(in-package :readline/tests)
5.11+
5.12+(defsuite :readline)
5.13+(in-suite :readline)
5.14+
5.15+(load-readline)
5.16+
5.17+(deftest readline ()
5.18+ (is readline::*history-base*)
5.19+ (is readline::*history-length*))
5.20+
6.1--- a/lisp/lib/cli/clap.lisp Tue May 28 17:55:30 2024 -0400
6.2+++ b/lisp/lib/cli/clap.lisp Tue May 28 23:12:31 2024 -0400
6.3@@ -37,19 +37,20 @@
6.4 (defvar *no-exit* nil
6.5 "Indicate whether the WITH-CLI-HANDLERS form should exit on completion.")
6.6
6.7-(defmacro with-cli-handlers (form)
6.8+(defmacro with-cli-handlers (&body body)
6.9 "A wrapper which handles common cli errors that may occur during
6.10-evaluation of FORM."
6.11+evaluation of BODY."
6.12 `(progn
6.13 (if *no-exit*
6.14 (sb-ext:enable-debugger)
6.15 (sb-ext:disable-debugger))
6.16- (handler-case ,form
6.17- (sb-sys:interactive-interrupt ()
6.18- (println "(:SIGINT)")
6.19- (sb-ext:exit :code 130))
6.20- ;; ,@(when *no-exit* '()))
6.21- )))
6.22+ (unwind-protect
6.23+ (handler-case (progn ,@body)
6.24+ (sb-sys:interactive-interrupt ()
6.25+ (println "(:SIGINT)")
6.26+ (sb-ext:exit :code 130)))
6.27+ ;; reset terminal state
6.28+ (.ris))))
6.29
6.30 (defmacro with-cli (slots cli &body body)
6.31 "Like with-slots with some extra bindings."
6.32@@ -97,18 +98,17 @@
6.33 %class (cdr name)))
6.34 `(,*default-cli-def* ,%name (apply #'make-cli ,%class (walk-cli-slots ',body)))))
6.35
6.36-(defmacro defmain ((&key return (exit t)) &body body)
6.37+(defmacro defmain ((&key return (exit t) (export t)) &body body)
6.38 "Define a CLI main function in the current package."
6.39 (with-gensyms (retval)
6.40- (let ((main (symbolicate 'main)))
6.41+ (let ((main (symbolicate "MAIN")))
6.42 (when return (setf retval return))
6.43- `(prog1
6.44- (defun ,main ()
6.45- "Run the top-level function and print to *STDOUT*."
6.46- (let ((*no-exit* ,(not exit)))
6.47- (with-cli-handlers
6.48- (progn ,@body ,@(unless (not (boundp 'retval)) (list retval))))))
6.49- (export '(,main))))))
6.50+ `(let ((*no-exit* ,(not exit)))
6.51+ (defun ,main ()
6.52+ "Run the top-level function and print to *STDOUT*."
6.53+ (with-cli-handlers
6.54+ (progn ,@body ,@(unless (not (boundp 'retval)) (list retval)))))
6.55+ ,@(when export `((export ',main)))))))
6.56
6.57 ;;; Utils
6.58 (defun make-cli (kind &rest slots)
6.59@@ -238,7 +238,7 @@
6.60
6.61 (defun cli-opt-kind-p (s)
6.62 (declare (type symbol s))
6.63- (find s *cli-opt-kinds*))
6.64+ (find s *cli-opt-kinds* :test 'string-equal))
6.65
6.66 ;; TODO 2024-03-16: this should map directly to Lisp types (fixnum, boolean, etc)
6.67 (eval-always
6.68@@ -250,13 +250,11 @@
6.69 (super (when (consp kind-spec) (cadr kind-spec)))
6.70 (fn-name (symbolicate 'parse- kind '-opt)))
6.71 ;; thread em
6.72- (let ((fn1 (when (not (eql 'nil super)) (symbolicate 'parse- super '-opt))))
6.73- `(progn
6.74- (defun ,fn-name ($val)
6.75- "Parse the cli-opt-val $VAL."
6.76- ;; do stuff
6.77- (when (not (eql ',fn1 'nil)) (setq $val (funcall ',fn1 $val)))
6.78- ,@body)))))
6.79+ (let ((fn1 (unless (null super) (symbolicate 'parse- super '-opt))))
6.80+ `(defun ,fn-name ($val)
6.81+ "Parse the cli-opt-val $VAL."
6.82+ ,@(when fn1 `((setq $val (funcall #',fn1 $val))))
6.83+ ,@body))))
6.84
6.85 (make-opt-parser bool $val)
6.86
7.1--- a/lisp/lib/cli/cli.asd Tue May 28 17:55:30 2024 -0400
7.2+++ b/lisp/lib/cli/cli.asd Tue May 28 23:12:31 2024 -0400
7.3@@ -1,6 +1,6 @@
7.4 ;;; cli.asd --- CLI library
7.5 (defsystem :cli
7.6- :depends-on (:std :log #+readline :cl-readline)
7.7+ :depends-on (:std :log)
7.8 :components ((:file "pkg")
7.9 (:file "ansi" :depends-on ("pkg"))
7.10 (:file "env" :depends-on ("pkg"))
8.1--- a/lisp/lib/cli/pkg.lisp Tue May 28 17:55:30 2024 -0400
8.2+++ b/lisp/lib/cli/pkg.lisp Tue May 28 23:12:31 2024 -0400
8.3@@ -85,7 +85,7 @@
8.4 :vspark :*vticks*))
8.5
8.6 (defpackage :cli/repl
8.7- (:use :cl :std :cli/progress :cli/spark #+readline :cl-readline)
8.8+ (:use :cl :std :cli/progress :cli/spark)
8.9 (:export :load-acl-repl :start-rl-repl))
8.10
8.11 (defpackage :cli/ed
8.12@@ -96,6 +96,7 @@
8.13 (defpackage :cli/clap
8.14 (:nicknames :clap)
8.15 (:use :cl :std :log :sb-ext)
8.16+ (:import-from :cli/ansi :.ris)
8.17 (:import-from :uiop :println)
8.18 (:import-from :sb-ext :parse-native-namestring)
8.19 (:shadowing-import-from :sb-ext :exit)
8.20@@ -108,6 +109,7 @@
8.21 :command-line-args
8.22 :*cli-group-separator*
8.23 :*cli-opt-kinds*
8.24+ :cli-opt-kind-p
8.25 :global-opt-p
8.26 :*std-local-env-var-names*
8.27 :*std-global-env-var-names*
8.28@@ -165,8 +167,8 @@
8.29 :cli-cmd
8.30 :cli-cd
8.31 :find-cmd
8.32- :find-opt
8.33- :find-short-opt
8.34+ :find-opts
8.35+ :find-short-opts
8.36 :install-ast
8.37 ;; :gen-cli-thunk
8.38 :install-thunk
8.39@@ -191,11 +193,13 @@
8.40 (:use :cl :std)
8.41 (:export))
8.42
8.43-(uiop:define-package :cli
8.44- (:use :cl :std)
8.45+(in-package :std-user)
8.46+
8.47+(defpkg :cli
8.48+ (:use :cl :std)
8.49 (:use-reexport :cli/shell :cli/ansi :cli/prompt
8.50 :cli/progress :cli/spark :cli/prompt :cli/ed
8.51 :cli/repl :cli/clap))
8.52
8.53-(defpackage :cli-user
8.54- (:use :cl :std :cli))
8.55+(defpkg :cli-user (:use :cl :std :cli))
8.56+
9.1--- a/lisp/lib/cli/repl.lisp Tue May 28 17:55:30 2024 -0400
9.2+++ b/lisp/lib/cli/repl.lisp Tue May 28 23:12:31 2024 -0400
9.3@@ -1,10 +1,5 @@
9.4 ;;; lib/cli/repl.lisp --- REPL utils
9.5
9.6-;; For now we rely on Vindarel's excellent CL-READLINE package, which
9.7-;; provides bindings to the GNU Readline library and a nice API.
9.8-
9.9-;; ref: https://github.com/vindarel/cl-readline
9.10-
9.11 ;;; Code:
9.12 (in-package :cli/repl)
9.13 ;; *command-char* alias make-repl-fun
10.1--- a/lisp/lib/cli/tests.lisp Tue May 28 17:55:30 2024 -0400
10.2+++ b/lisp/lib/cli/tests.lisp Tue May 28 23:12:31 2024 -0400
10.3@@ -7,18 +7,19 @@
10.4
10.5 (defun ansi-t01 ()
10.6 (erase)
10.7- (cursor-position 0 0)
10.8- (princ "0")
10.9- (cursor-position 2 2)
10.10- (princ "1")
10.11- (cursor-position 5 15)
10.12- (princ "test")
10.13- (cursor-position 10 15)
10.14- (force-output)
10.15- (let ((a (read-line)))
10.16- (cursor-position 12 15)
10.17- (princ a)
10.18- (force-output)))
10.19+ (cursor-position 0 0)
10.20+ (princ "0")
10.21+ (cursor-position 2 2)
10.22+ (princ "1")
10.23+ (cursor-position 5 15)
10.24+ (princ "test")
10.25+ (cursor-position 10 15)
10.26+ (force-output)
10.27+ (with-input-from-string (in (format nil "test~%~%"))
10.28+ (let ((a (read-line in)))
10.29+ (cursor-position 12 15)
10.30+ (princ a)
10.31+ (force-output))))
10.32
10.33 (defun ansi-t02 ()
10.34 (print "normal")
10.35@@ -44,13 +45,13 @@
10.36 "Display the 256 color palette."
10.37 (clear)
10.38 (loop for i from 0 to 255 do
10.39- (.sgr 48 5 i)
10.40- (princ #\space))
10.41+ (.sgr 48 5 i)
10.42+ (princ #\space))
10.43 (terpri)
10.44 (.sgr 0)
10.45 (loop for i from 0 to 255 do
10.46- (.sgr 38 5 i)
10.47- (princ "X"))
10.48+ (.sgr 38 5 i)
10.49+ (princ "X"))
10.50 (.sgr 0)
10.51 (force-output)
10.52 (sleep 3)
10.53@@ -187,18 +188,19 @@
10.54 (nreverse chars)))
10.55
10.56 (deftest ansi ()
10.57- ;; (ansi-t01)
10.58- (ansi-t02)
10.59- (ansi-t03)
10.60- (ansi-t04)
10.61- ;;(ansi-t05)
10.62-)
10.63+ (with-input-from-string (in (format nil "~%~%"))
10.64+ (ansi-t01)
10.65+ (ansi-t02)
10.66+ (ansi-t03)
10.67+ (ansi-t04)
10.68+ (ansi-t05)))
10.69
10.70-(deftest cli-prompt (:disabled nil) ;; FIXME: hijacks io in slime
10.71+;; TODO: needs to be compiled outside scope of test - contender for
10.72+;; fixture API
10.73+(defprompt tpfoo "testing: ")
10.74+
10.75+(deftest cli-prompt ()
10.76 "Test CLI prompts"
10.77- ;; TODO: needs to be compiled outside scope of test - contender for
10.78- ;; fixture API
10.79- (defprompt tpfoo "testing: ")
10.80 (defvar tcoll nil)
10.81 (defvar thist nil)
10.82 (let ((*standard-input* (make-string-input-stream
10.83@@ -218,15 +220,15 @@
10.84
10.85 (defparameter *cli* (make-cli :cli :opts *opts* :cmds *cmds* :description "test cli"))
10.86
10.87-(deftest cli ()
10.88- "test MACS.CLI OOS."
10.89+(deftest clap-basic ()
10.90+ "test basic CLAP functionality."
10.91 (let ((cli *cli*))
10.92 (is (eq (make-shorty "test") #\t))
10.93 (is (equalp (proc-args cli '("-f" "baz" "--bar" "fax")) ;; not eql
10.94 (make-cli-ast
10.95- (list (make-cli-node 'opt (find-short-opt cli #\f))
10.96+ (list (make-cli-node 'opt (find-short-opts cli #\f))
10.97 (make-cli-node 'cmd (find-cmd cli "baz"))
10.98- (make-cli-node 'opt (find-opt cli "bar"))
10.99+ (make-cli-node 'opt (find-opts cli "bar"))
10.100 (make-cli-node 'arg "fax")))))
10.101 (is (parse-args cli '("--bar" "baz" "-f" "yaks")))
10.102 (is (stringp
10.103@@ -236,6 +238,14 @@
10.104 (print-help cli s))))
10.105 (is (string= "foobar" (parse-str-opt "foobar")))))
10.106
10.107+(deftest clap-opts ()
10.108+ "CLAP opt tests."
10.109+ (is (reduce (lambda (x y) (when x (when y t)))
10.110+ (loop for k across *cli-opt-kinds* collect (cli-opt-kind-p k))))
10.111+ (make-opt-parser thing $val)
10.112+ (is (parse-thing-opt t))
10.113+ (is (null (parse-thing-opt nil))))
10.114+
10.115 (deftest progress ()
10.116 (flet ((%step () (cli/progress::update 1)))
10.117 (let ((*progress-bar-enabled* t)
10.118@@ -659,12 +669,11 @@
10.119
10.120 (deftest clap-ast ())
10.121
10.122-(defvar *test-target* nil)
10.123-
10.124 (deftest main-output ()
10.125- (defmain (:return *test-target* :exit nil)
10.126- (let ((*test-target* t))
10.127- *test-target*))
10.128- (compile 'main)
10.129- (is (main))
10.130- (is (null *test-target*)))
10.131+ (let ((*test-target*))
10.132+ (defmain (:return *test-target* :exit nil :export nil)
10.133+ (let ((*test-target* t))
10.134+ *test-target*))
10.135+ (compile 'main)
10.136+ (is (main))
10.137+ (is (null *test-target*))))
11.1--- a/lisp/lib/net/codec/tlv.lisp Tue May 28 17:55:30 2024 -0400
11.2+++ b/lisp/lib/net/codec/tlv.lisp Tue May 28 23:12:31 2024 -0400
11.3@@ -55,8 +55,6 @@
11.4 (read-sequence value from)
11.5 (make-tlv type length value))))))
11.6
11.7-
11.8-
11.9 (defmethod serde ((from tlv) (to simple-array))
11.10 (with-slots (type length value) from
11.11 (setf (aref to 0) type)
12.1--- a/lisp/lib/net/pkg.lisp Tue May 28 17:55:30 2024 -0400
12.2+++ b/lisp/lib/net/pkg.lisp Tue May 28 23:12:31 2024 -0400
12.3@@ -21,20 +21,36 @@
12.4
12.5 (defpackage :net/sans-io
12.6 (:use :cl :obj :dat/proto :std :net/core :sb-bsd-sockets)
12.7- (:export))
12.8+ (:export :sans-io-protocol :protocol-version :protocol-name :protocol-features
12.9+ :*max-connection-id* :*initial-mtu* :*max-stream-count* :*max-udp-payload*
12.10+ :*word-length* :sans-io-error :packet-serializer-error :packet-deserializer-error
12.11+ :packet-header-serializer-error :packet-header-deserializer-error :frame-serializer-error :frame-deserializer-error
12.12+ :stream-id :stream-direction :event-id :event
12.13+ :endpoint-event :connection-event :connection-id :connection-id-generator
12.14+ :connection :connection-idle-timeout :peer-id :peer-address
12.15+ :peer :clientp :serverp :endpoint-config
12.16+ :transport-config :server-config :client-config :endpoint
12.17+ :handle-event :handle :connect :default-client-config
12.18+ :packet-number :packet-header :packet-payload :packet
12.19+ :frame :size-bound :frame-type :with-endpoint
12.20+ :with-client :define-protocol :define-endpoint :define-event
12.21+ :define-handler))
12.22
12.23 (defpackage :net/udp
12.24 (:nicknames :udp)
12.25 (:use :cl :std :net/core :sb-bsd-sockets)
12.26 (:export
12.27 :udp-server
12.28+ :with-udp-client
12.29+ :with-udp-server
12.30 :with-udp-client-and-server))
12.31
12.32 (defpackage :net/tcp
12.33 (:nicknames :tcp)
12.34 (:use :cl :std :net/core :sb-bsd-sockets)
12.35 (:export
12.36- :tcp-server))
12.37+ :tcp-server
12.38+ :with-tcp-client))
12.39
12.40 (defpackage :net/codec/punycode
12.41 (:nicknames :codec/punycode)
12.42@@ -305,12 +321,19 @@
12.43 :retry-request
12.44 :ignore-and-continue))
12.45
12.46-(uiop:define-package :net/fetch
12.47+(defpackage :net/fetch
12.48 (:nicknames :fetch)
12.49 (:use :cl :std :obj/uri)
12.50 (:export :fetch :download))
12.51
12.52-(uiop:define-package :net
12.53+(defpackage :net/srv
12.54+ (:nicknames :srv)
12.55+ (:use :cl :std :obj/uri :net/core :net/proto/http :net/sans-io :net/cookie :dat/base64 :sb-gray)
12.56+ (:export))
12.57+
12.58+(in-package :std-user)
12.59+
12.60+(defpkg :net
12.61 (:use-reexport
12.62 :net/core
12.63 :net/tcp
13.1--- a/lisp/lib/net/proto/http.lisp Tue May 28 17:55:30 2024 -0400
13.2+++ b/lisp/lib/net/proto/http.lisp Tue May 28 23:12:31 2024 -0400
13.3@@ -810,7 +810,7 @@
13.4 status-text)
13.5
13.6 ;;; Errors
13.7-(define-condition http-error (net-error)
13.8+(define-condition http-error (protocol-error)
13.9 (description)
13.10 (:report
13.11 (lambda (condition stream)
13.12@@ -848,7 +848,6 @@
13.13 (define-condition cb-status (callback-error)
13.14 ((description :initform "the status callback failed")))
13.15
13.16-
13.17 ;;
13.18 ;; Parsing-related errors
13.19
14.1--- a/lisp/lib/net/sans-io.lisp Tue May 28 17:55:30 2024 -0400
14.2+++ b/lisp/lib/net/sans-io.lisp Tue May 28 23:12:31 2024 -0400
14.3@@ -8,104 +8,142 @@
14.4
14.5 ;;; Code:
14.6 (in-package :net/sans-io)
14.7+
14.8 ;;; Abstract
14.9 (defclass sans-io-protocol ()
14.10- ((version :initarg :version)
14.11- (features :initarg :features)))
14.12-(defmethod protocol-version ((self sans-io-protocol)) 0)
14.13-(defmethod protocol-name ((self sans-io-protocol)) "sans-io")
14.14+ ((version :initarg :version :accessor protocol-version)
14.15+ (features :initarg :features :accessor protocol-features)))
14.16+
14.17+(defmethod protocol-name ((self sans-io-protocol)) (class-name (class-of self)))
14.18+
14.19 ;;; Parameters
14.20 (defvar *word-length* 64)
14.21 (defvar *max-connection-id* sb-ext:most-positive-word)
14.22 (defvar *initial-mtu* 1200)
14.23 (defvar *max-udp-payload* 65527)
14.24 (defvar *max-stream-count* (ash 1 60))
14.25+
14.26 ;;; Errors
14.27-(define-condition sans-io-error (std-error) ())
14.28-(define-condition packet-serializer-error (serializer-error) ())
14.29-(define-condition packet-deserializer-error (deserializer-error) ())
14.30-(define-condition packet-header-serializer-error (serializer-error) ())
14.31-(define-condition packet-header-deserializer-error (deserializer-error) ())
14.32-(define-condition frame-serializer-error (serializer-error) ())
14.33-(define-condition frame-deserializer-error (deserializer-error) ())
14.34+(define-condition sans-io-error (protocol-error) ())
14.35+(define-condition packet-serializer-error (sans-io-error serializer-error) ())
14.36+(define-condition packet-deserializer-error (sans-io-error deserializer-error) ())
14.37+(define-condition packet-header-serializer-error (sans-io-error serializer-error) ())
14.38+(define-condition packet-header-deserializer-error (sans-io-error deserializer-error) ())
14.39+(define-condition frame-serializer-error (sans-io-error serializer-error) ())
14.40+(define-condition frame-deserializer-error (sans-io-error deserializer-error) ())
14.41+
14.42 ;;; IO
14.43 (defclass stream-id (id) ())
14.44 (defclass byte-buffer () ())
14.45 (defclass datagram-buffer () ())
14.46+
14.47 (defgeneric stream-direction ())
14.48+
14.49 ;;; Events
14.50 (defclass event-id (id) ())
14.51+
14.52 (defmethod make-id ((self (eql :event)))
14.53 (declare (ignorable self))
14.54 (make-instance 'event-id))
14.55 (defmethod reset-id ((self event-id)) (setf (id self) 0))
14.56 (defmethod update-id ((self event-id)) (setf (id self) (hash-object self)))
14.57+
14.58 (defclass event (event-id) ())
14.59+
14.60 (defclass endpoint-event (event) ())
14.61 (defclass connection-event (event) ())
14.62+
14.63 ;;; Connections
14.64 (defclass connection-id (id) ())
14.65+
14.66 (defclass connection-id-generator () ())
14.67 (defmethod make-id ((self (eql :connection)))
14.68 (declare (ignorable self))
14.69 (make-instance 'connection-id))
14.70 (defmethod reset-id ((self connection-id)) (setf (id self) 0))
14.71 (defmethod update-id ((self connection-id)) (setf (id self) (hash-object self)))
14.72+
14.73 (defclass connection (connection-id) ())
14.74+
14.75 (defclass connection-idle-timeout ()
14.76 ((timeout :initform 10000 ;; 10 seconds
14.77 :type (integer 0 *))))
14.78+
14.79 ;;; Peers
14.80 (defclass peer-id (id) ())
14.81+
14.82 (defmethod make-id ((self (eql :peer)))
14.83 (declare (ignorable self))
14.84 (make-instance 'peer-id))
14.85 (defmethod reset-id ((self peer-id)) (setf (id self) 0))
14.86 (defmethod update-id ((self peer-id)) (setf (id self) (hash-object self)))
14.87-(defclass peer-address (id) ())
14.88+
14.89+(defclass peer-address () ((address :initarg :address)))
14.90+
14.91 (defclass peer (peer-id peer-address) ())
14.92-(defgeneric clientp ())
14.93-(defgeneric serverp ())
14.94+
14.95+(defgeneric clientp (self)
14.96+ (:documentation "Return non-nil if SELF is a valid CLIENT."))
14.97+
14.98+(defgeneric serverp ()
14.99+ (:documentation "Return non-nil if SELF is a valid SERVER."))
14.100+
14.101 ;;; Endpoints
14.102 (defclass endpoint-config ()
14.103 ((socket :initarg :socket :type socket)
14.104 (id-factory :initarg :id-factory :type id-factory)
14.105- (features :initarg :features)))
14.106-
14.107-(defclass transport-config () ())
14.108+ (features :initarg :features))
14.109+ (:documentation "Configuration for ENDPOINTs, affecting all connections."))
14.110
14.111-(defclass server-config ()
14.112- ((transport :initarg :transport :type transport-config)))
14.113+(defclass transport-config () ()
14.114+ (:documentation "Configuration for a network protocol state machine."))
14.115
14.116-(defclass client-config ()
14.117- ((transport :initarg :transport :type transport-config)))
14.118+(defclass server-config (transport-config) ())
14.119+
14.120+(defclass client-config (transport-config) ())
14.121
14.122 (defclass endpoint (endpoint-config connection-id-generator)
14.123 ((connections :initform #() :type (array connection))
14.124- (server :initarg :server :initform nil :type (or null server-config))))
14.125+ (server :initarg :server)
14.126+ (client :initarg :client)))
14.127+
14.128 (defgeneric handle-event ())
14.129 (defgeneric handle ())
14.130 (defgeneric connect ())
14.131 (defgeneric default-client-config ())
14.132+
14.133 ;;; Packets
14.134 (defclass packet-number (id) ())
14.135-(defclass packet-header (packet-number) ())
14.136+(defclass packet-header (packet-number) (header))
14.137 (defclass packet-payload () (payload))
14.138-(defclass packet (packet-header packet-payload) ())
14.139+(defclass packet (packet-payload) ())
14.140+
14.141 (defmethod serialize ((self packet) format &key &allow-other-keys))
14.142 (defmethod deserialize ((self packet) format &key &allow-other-keys))
14.143+
14.144 (defmethod serialize ((self packet-header) format &key &allow-other-keys))
14.145 (defmethod deserialize ((self packet-header) format &key &allow-other-keys))
14.146+
14.147 ;;; Frames
14.148 (defclass frame () ())
14.149+
14.150 (defgeneric size-bound ())
14.151 (defgeneric frame-type ())
14.152+
14.153 (defmethod serialize ((self frame) format &key &allow-other-keys))
14.154 (defmethod deserialize ((self frame) format &key &allow-other-keys))
14.155+
14.156 ;;; Macros
14.157-(defmacro define-protocol (&environment env name from-protocols &rest options))
14.158-(defmacro define-endpoint (name &rest options))
14.159-(defmacro define-event (name &rest options))
14.160-(defmacro define-handler (name &body body))
14.161+(defmacro define-protocol (name superclasses slots &key version features)
14.162+ "Define a network protocol based on SANS-IO-PROTOCOL."
14.163+ `(defclass ,name (,@(or superclasses (list 'sans-io-protocol)))
14.164+ ,slots
14.165+ (:default-initargs
14.166+ :version ,version
14.167+ :features ,features)))
14.168+
14.169+;; (defmacro define-endpoint (name &rest options))
14.170+;; (defmacro define-event (name &rest options))
14.171+;; (defmacro define-handler (name &body body))
14.172 (defmacro with-endpoint ())
14.173 (defmacro with-client ())
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/lib/net/srv.lisp Tue May 28 23:12:31 2024 -0400
15.3@@ -0,0 +1,28 @@
15.4+;;; net/srv.lisp --- Lisp Web Services
15.5+
15.6+;; This library contains provides a Web Server abstraction a la Hunchentoot or
15.7+;; Woo.
15.8+
15.9+;;; Commentary:
15.10+
15.11+;; The code in this file is meant to be small. We want to leverage the core
15.12+;; ecosystem and internal NET/* packages to build high-level abstractions that
15.13+;; are still useful with minimal boilerplate.
15.14+
15.15+;; In other words we want to support both these use-cases in the least amount
15.16+;; of code:
15.17+#|
15.18+(srv:start (srv:file-server)) ;; start a simple HTTP file server in current directory with all default values
15.19+
15.20+(srv:define-web-service my-homepage :port 8080 :auth (auth settings ...) :routes (routes ...) &more ...)
15.21+(with-ws (ws 'my-homepage)
15.22+ (srv:start ws))
15.23+|#
15.24+
15.25+;;;; NET/SANS-IO
15.26+;; This package contains the low-level base classes which are extended by this
15.27+;; library.
15.28+
15.29+;;; Code:
15.30+(in-package :net/srv)
15.31+
16.1--- a/lisp/lib/net/tests.lisp Tue May 28 17:55:30 2024 -0400
16.2+++ b/lisp/lib/net/tests.lisp Tue May 28 23:12:31 2024 -0400
16.3@@ -1,5 +1,5 @@
16.4 (defpackage :net/tests
16.5- (:use :rt :std :cl :net :sb-concurrency :sb-thread))
16.6+ (:use :rt :std :cl :net :sb-concurrency :sb-thread :dat/proto))
16.7
16.8 (in-package :net/tests)
16.9
16.10@@ -8,7 +8,12 @@
16.11 (in-readtable :std)
16.12 (deftest sanity ())
16.13
16.14-(deftest sans-io (:disabled t)
16.15+(deftest sans-io ()
16.16+ (define-protocol mockz () (data) :version 2 :features (list :foo :bar :baz))
16.17+ (is (eql 'mockz (protocol-name (make-instance 'mockz))))
16.18+ (is (null (protocol-features (make-instance 'sans-io-protocol :features nil))))
16.19+ (is (= 3 (length (protocol-features (make-instance 'mockz)))))
16.20+ (is (= 2 (protocol-version (make-instance 'mockz))))
16.21 (defclass mock-transport-config (transport-config)
16.22 (max-bidi-streams
16.23 max-uni-streams
16.24@@ -23,13 +28,9 @@
16.25 (datagram-rx-buffer-size :initform 1250000)
16.26 (datagram-tx-buffer-size :initform (* 1024 1024))))
16.27 (defclass mock-server-config (server-config)
16.28- ((port :initarg :port :initform 0))
16.29- (:default-initargs
16.30- :transport (make-instance 'mock-transport-config)))
16.31+ ((port :initarg :port :initform 0)))
16.32 (defclass mock-client-config (client-config)
16.33- ((port :initarg :port :initform 0))
16.34- (:default-initargs
16.35- :transport (make-instance 'mock-transport-config)))
16.36+ ((port :initarg :port :initform 0)))
16.37 (defclass mock-endpoint (endpoint)
16.38 ((tx :initarg :tx)
16.39 (rx :initarg :rx))
16.40@@ -40,11 +41,16 @@
16.41
16.42 (deftest dns ())
16.43
16.44-(deftest tcp ())
16.45+(deftest tcp ()
16.46+ (with-tcp-client (client)
16.47+ (is (typep client 'sb-bsd-sockets:inet-socket))))
16.48
16.49-(deftest udp ())
16.50+(deftest udp ()
16.51+ (with-udp-client (client)
16.52+ (is (typep client 'sb-bsd-sockets:inet-socket))))
16.53
16.54-(deftest tlv ())
16.55+(deftest tlv ()
16.56+ (is (= 4 (length (serialize (make-instance 'tlv :type 0 :length 1 :value #(1)) :bytes)))))
16.57
16.58 (deftest osc ())
16.59
16.60@@ -137,3 +143,9 @@
16.61 "#))
16.62 (is cb)
16.63 (is req)))
16.64+
16.65+(deftest req ())
16.66+
16.67+(deftest fetch ())
16.68+
16.69+(deftest cookies ())
17.1--- a/lisp/lib/nlp/nlp.asd Tue May 28 17:55:30 2024 -0400
17.2+++ b/lisp/lib/nlp/nlp.asd Tue May 28 23:12:31 2024 -0400
17.3@@ -20,6 +20,6 @@
17.4
17.5
17.6 (defsystem :nlp/tests
17.7- :depends-on (:nlp :std :rt)
17.8+ :depends-on (:rt :log :nlp)
17.9 :components ((:file "tests"))
17.10- :in-order-to ((test-op (rt:do-tests :nlp))))
17.11+ :in-order-to ((test-op (uiop:symbol-call :rt :do-tests :nlp))))
18.1--- a/lisp/web/dash.lisp Tue May 28 17:55:30 2024 -0400
18.2+++ b/lisp/web/dash.lisp Tue May 28 23:12:31 2024 -0400
18.3@@ -2,8 +2,8 @@
18.4
18.5 ;;; Code:
18.6 (uiop:define-package :web/dash
18.7- (:use :cl :std :lack :lass :spinneret :cli/clap)
18.8- (:import-from :clack :clackup)
18.9+ (:use :cl :std #+nil :lass #+nil :spinneret :cli/clap)
18.10+ ;; (:import-from :clack :clackup)
18.11 (:export
18.12 :main
18.13 :serve-static-assets
18.14@@ -21,15 +21,11 @@
18.15 (print "starting dash server on ~A" port)
18.16 (handler-case (sb-thread:join-thread (find-if (lambda (th)
18.17 (search "hunchentoot" (sb-thread:thread-name th)))
18.18- (sb-thread:all-threads)))
18.19+ (sb-thread:list-all-threads)))
18.20 ;; Catch a user's C-c
18.21 (#+sbcl sb-sys:interactive-interrupt
18.22- #+ccl ccl:interrupt-signal-condition
18.23- #+clisp system::simple-interrupt-condition
18.24- #+ecl ext:interactive-interrupt
18.25- #+allegro excl:interrupt-signal
18.26 () (progn
18.27 (format *error-output* "Aborting.~&")
18.28- (clack:stop *server*)
18.29+ ;; (clack:stop *server*)
18.30 (uiop:quit)))
18.31 (error (c) (format t "Woops, an unknown error occured:~&~a~&" c)))))
19.1--- a/lisp/web/web.asd Tue May 28 17:55:30 2024 -0400
19.2+++ b/lisp/web/web.asd Tue May 28 23:12:31 2024 -0400
19.3@@ -1,8 +1,3 @@
19.4-(defsystem :web
19.5- :depends-on (:web/dash :web/index)
19.6- :in-order-to ((test-op (test-op "app/tests")))
19.7- :perform (test-op (o c) (symbol-call :rt :do-tests :app)))
19.8-
19.9 (defsystem :web/index
19.10 :depends-on (:uiop :cl-ppcre :std :rdb :hunchentoot :parenscript :lass :spinneret :organ)
19.11 :components ((:file "index"))
19.12@@ -12,9 +7,12 @@
19.13 :entry-point "app/web/index::main")
19.14
19.15 (defsystem :web/dash
19.16- :depends-on (:uiop :cl-ppcre :std :rdb :lack :clack :parenscript :lass :spinneret :organ)
19.17+ :depends-on (:uiop :cl-ppcre :std :rdb :parenscript :lass :spinneret :organ)
19.18 :components ((:file "dash"))
19.19 :in-order-to ((test-op (test-op "app/tests")))
19.20 :build-operation "program-op"
19.21 :build-pathname "web-dash"
19.22 :entry-point "app/web/dash::main")
19.23+
19.24+(defsystem :web
19.25+ :depends-on (:web/dash :web/index))
