# HG changeset patch # User ellis # Date 1686092117 14400 # Node ID 529419ac94f3fb3e56f221f13f8d885a2057b6cc # Parent 2015d7277629633c71b52b94aecf4719fdd93139 refactor 2 (wip) diff -r 2015d7277629 -r 529419ac94f3 demo.asd --- a/demo.asd Mon Jun 05 19:59:26 2023 -0400 +++ b/demo.asd Tue Jun 06 18:55:17 2023 -0400 @@ -1,41 +1,25 @@ ;;; demo.asd (in-package #:asdf-user) +(defsystem "demo/sys" + :components ((:file "src/package"))) + (defsystem "demo" :version "0.1.0" :author "ellis " :maintainer "ellis " :description "" :homepage "https://rwest.io/p/demo" - :bug-tracker "https://gitlab.rwest.io/ellis/demo/issues" - :source-control (:hg "https://gitlab.rwest.io/ellis/demo") + :bug-tracker "https://lab.rwest.io/otom8/demo/issues" + :source-control (:hg "https://lab.rwest.io/otom8/demo") :license "WTFPL" - :depends-on ("demo/sys" "demo/db" "demo/ui" "demo/cli") + :depends-on ("demo/sys" :cl-dbi :sxql :log4cl :verbose :bordeaux-threads :clingon :clog) :in-order-to ((test-op (test-op "src/test"))) :build-pathname "demo") -(defsystem "demo/sys" - :depends-on (:sxql :log4cl) - :components ((:file "src/packages") - (:module "tk" - :pathname "src/tk" - :serial t - :components ((:file "tk") - (:file "rs" :depends-on ("tk")))))) - (defmethod perform :after ((op load-op) (c (eql (find-system :demo)))) (pushnew :demo *features*)) -(defsystem "demo/cli" - :depends-on (:clingon "demo/sys" "demo/ui" "demo/db") - :components ((:file "src/cli"))) -(defsystem "demo/ui" - :depends-on (:clog "demo/sys" "demo/db") - :components ((:file "src/ui"))) -(defsystem "demo/db" - :depends-on (:cl-dbi "demo/sys") - :components ((:file "src/db"))) - (defsystem "demo/tests" :depends-on ("demo" "fiveam") :components ((:module "src/tests" diff -r 2015d7277629 -r 529419ac94f3 readme.org --- a/readme.org Mon Jun 05 19:59:26 2023 -0400 +++ b/readme.org Tue Jun 06 18:55:17 2023 -0400 @@ -6,11 +6,12 @@ * How it works The backend services are written in Rust and controlled by a simple messaging protocol. Services provide common runtime capabilities known -as the /core protocol/ but are specialized on a unique /service type/ -which may in turn register their own /custom protocols/ (via core). +as the /service protocol/ but are specialized on a unique /service +type/ which may in turn register their own /custom protocols/ (via +core). Services are capable of dispatching data directly to clients, or -storing data in the /database/ (TBD). +storing data in the /database/ (sqlite, postgres, mysql). The frontend clients are pre-dominantly written in Common Lisp and come in many shapes and sizes. There is a cli-client, web-client @@ -20,6 +21,9 @@ * Guide ** Build - *install dependencies* + #+begin_src bash + ./tools/deps.sh + #+end_src - Rust =curl --proto '=https' --tlsv1.2 -sSf https://sh.rustup.rs | sh= - Common Lisp - on Linux :: diff -r 2015d7277629 -r 529419ac94f3 src/build.rs --- a/src/build.rs Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -use std::env; -use std::fs::create_dir; -use std::path::PathBuf; -fn main() { - let crate_dir: PathBuf = env::var("CARGO_MANIFEST_DIR") - .expect("CARGO_MANIFEST_DIR env var is not defined") - .into(); - // let mpk_py = "build.py"; - let build_dir = crate_dir.join("ffi/"); - if !build_dir.exists() { - create_dir(&build_dir).unwrap(); - } - cbindgen::generate(crate_dir) - .expect("Unable to find cbindgen.toml configuration file") - .write_to_file(build_dir.join("demo.h")); - -} diff -r 2015d7277629 -r 529419ac94f3 src/cbindgen.toml --- a/src/cbindgen.toml Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -include_guard = "demo_h" -autogen_warning = "/* DO NOT TOUCH */" -include_version = true -language = "C" -cpp_compat = true -line_length = 88 -documentation = true -[parse] -parse_deps = true -include = ["obj","fig","libc"] -extra_bindings = ["obj","fig","libc"] -#expand = ["demo","obj"] -#[parse.expand] -#crates = ["demo"] \ No newline at end of file diff -r 2015d7277629 -r 529419ac94f3 src/db/db.lisp --- a/src/db/db.lisp Mon Jun 05 19:59:26 2023 -0400 +++ b/src/db/db.lisp Tue Jun 06 18:55:17 2023 -0400 @@ -1,197 +1,1 @@ -(in-package :demo) - -(define-foreign-library rocksdb - (:win32 "rocksdb") - (t (:default "librocksdb"))) - -(use-foreign-library rocksdb) - -(defcfun ("rocksdb_options_create" create-options) :pointer) -(defcfun ("rocksdb_options_destroy" destroy-options) :void (options :pointer)) -(defcfun ("rocksdb_options_increase_parallelism" increase-parallelism) :void (opt :pointer) (total-threads :int)) -(defcfun ("rocksdb_options_optimize_level_style_compaction" optimize-level-style-compaction) :void (opt :pointer) (memtable_memory_budget :uint64)) -(defcfun ("rocksdb_options_set_create_if_missing" set-create-if-missing) :void (opt :pointer) (val :boolean)) - -(defcfun ("rocksdb_writeoptions_create" create-writeoptions) :pointer) -(defcfun ("rocksdb_writeoptions_destroy" destroy-writeoptions) :void (opt :pointer)) -(defcfun ("rocksdb_readoptions_create" create-readoptions) :pointer) -(defcfun ("rocksdb_readoptions_destroy" destroy-readoptions) :void (opt :pointer)) - -(defcfun ("rocksdb_open" open-db*) :pointer (opt :pointer) (name :string) (errptr :pointer)) -(defcfun ("rocksdb_close" close-db) :void (opt :pointer)) -(defcfun ("rocksdb_cancel_all_background_work" cancel-all-background-work) :void (db :pointer) (wait :boolean)) - -(defcfun ("rocksdb_put" put*) :void (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (val :pointer) (vallen :unsigned-int) (errptr :pointer)) -(defcfun ("rocksdb_get" get*) :pointer (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (vallen :pointer) (errptr :pointer)) - -(defcfun ("rocksdb_create_iterator" create-iter*) :pointer (db :pointer) (opt :pointer)) -(defcfun ("rocksdb_iter_destroy" destroy-iter) :void (iter :pointer)) -(defcfun ("rocksdb_iter_seek_to_first" move-iter-to-first) :void (iter :pointer)) -(defcfun ("rocksdb_iter_valid" valid-iter-p) :boolean (iter :pointer)) -(defcfun ("rocksdb_iter_next" move-iter-forward) :void (iter :pointer)) -(defcfun ("rocksdb_iter_prev" move-iter-backward) :void (iter :pointer)) -(defcfun ("rocksdb_iter_key" iter-key*) :pointer (iter :pointer) (klen-ptr :pointer)) -(defcfun ("rocksdb_iter_value" iter-value*) :pointer (iter :pointer) (vlen-ptr :pointer)) - -(define-condition unable-to-open-db (error) - ((db-path :initarg :db-path - :reader db-path) - (error-message :initarg :error-message - :reader error-message))) - -(defmethod print-object ((obj unable-to-open-db) stream) - (print-unreadable-object (obj stream :type t :identity t) - (format stream "error-message=~A" (error-message obj)))) - -(define-condition unable-to-put-key-value-to-db (error) - ((db :initarg :db - :reader db) - (key :initarg :key - :reader key) - (val :initarg :val - :reader val) - (error-message :initarg :error-message - :reader error-message))) - -(define-condition unable-to-get-value-to-db (error) - ((db :initarg :db - :reader db) - (key :initarg :key - :reader key) - (error-message :initarg :error-message - :reader error-message))) - -(defun open-db (db-path &optional opt) - (unless opt - (setq opt (create-options))) - (let ((errptr (foreign-alloc :pointer))) - (setf (mem-ref errptr :pointer) (null-pointer)) - (let* ((db-path (if (pathnamep db-path) - (namestring db-path) - db-path)) - (db (open-db* opt db-path errptr)) - (err (mem-ref errptr :pointer))) - (unless (null-pointer-p err) - (error 'unable-to-open-db - :db-path db-path - :error-message (foreign-string-to-lisp err))) - db))) - -(defmacro clone-octets-to-foreign (lisp-array foreign-array) - (let ((i (gensym))) - `(loop for ,i from 0 below (length ,lisp-array) - do (setf (mem-aref ,foreign-array :unsigned-char ,i) - (aref ,lisp-array ,i))))) - -(defmacro clone-octets-from-foreign (foreign-array lisp-array len) - (let ((i (gensym))) - `(loop for ,i from 0 below ,len - do (setf (aref ,lisp-array ,i) - (mem-aref ,foreign-array :unsigned-char ,i))))) - -(defun put-kv (db key val &optional opt) - (unless opt - (setq opt (create-writeoptions))) - (with-foreign-objects ((errptr :pointer) - (key* :unsigned-char (length key)) - (val* :unsigned-char (length val))) - (clone-octets-to-foreign key key*) - (clone-octets-to-foreign val val*) - (setf (mem-ref errptr :pointer) (null-pointer)) - (put* db - opt - key* - (length key) - val* - (length val) - errptr) - (let ((err (mem-ref errptr :pointer))) - (unless (null-pointer-p err) - (error 'unable-to-put-key-value-to-db - :db db - :key key - :val val - :error-message (foreign-string-to-lisp err)))))) - -(defun put-kv-str (db key val &optional opt) - (let ((key-octets (babel:string-to-octets key)) - (val-octets (babel:string-to-octets val))) - (put-kv db key-octets val-octets opt))) - -(defun get-kv (db key &optional opt) - (unless opt - (setq opt (create-readoptions))) - - (with-foreign-objects ((val-len-ptr :unsigned-int) - (errptr :pointer) - (key* :unsigned-char (length key))) - (clone-octets-to-foreign key key*) - (setf (mem-ref errptr :pointer) (null-pointer)) - (let ((val (get* db - opt - key* - (length key) - val-len-ptr - errptr))) - (let ((err (mem-ref errptr :pointer))) - (unless (null-pointer-p err) - (error 'unable-to-get-value-to-db - :db db - :key key - :error-message (foreign-string-to-lisp err))) - - (unless (null-pointer-p val) - (let* ((val-len (mem-ref val-len-ptr :unsigned-int)) - (val* (make-array val-len - :element-type '(unsigned-byte 8)))) - (clone-octets-from-foreign val val* val-len) - val*)))))) - -(defun get-kv-str (db key &optional opt) - (let ((key-octets (babel:string-to-octets key))) - (let ((#1=val-octets (get-kv db key-octets opt))) - (when #1# - (babel:octets-to-string #1#))))) - -(defun create-iter (db &optional opt) - (unless opt - (setq opt (create-readoptions))) - (create-iter* db opt)) - -(defun iter-key (iter) - (with-foreign-objects ((klen-ptr :unsigned-int)) - (setf (mem-ref klen-ptr :unsigned-int) 0) - (let* ((key-ptr (iter-key* iter klen-ptr)) - (klen (mem-ref klen-ptr :unsigned-int)) - (key (make-array klen :element-type '(unsigned-byte 8)))) - (clone-octets-from-foreign key-ptr key klen) - key))) - -(defun iter-key-str (iter) - (let ((#1=key-octets (iter-key iter))) - (when #1# - (babel:octets-to-string #1#)))) - -(defun iter-value (iter) - (with-foreign-objects ((len-ptr :unsigned-int)) - (setf (mem-ref len-ptr :unsigned-int) 0) - (let* ((value-ptr (iter-value* iter len-ptr)) - (vlen (mem-ref len-ptr :unsigned-int)) - (value* (make-array vlen :element-type '(unsigned-byte 8)))) - (clone-octets-from-foreign value-ptr value* vlen) - value*))) - -(defun iter-value-str (iter) - (let ((#1=val-octets (iter-value iter))) - (when #1# - (babel:octets-to-string #1#)))) - -(defmacro with-open-db ((db-var db-path &optional opt) &body body) - `(let ((,db-var (open-db ,db-path ,opt))) - (unwind-protect (progn ,@body) - (close-db ,db-var)))) - -(defmacro with-iter ((iter-var db &optional opt) &body body) - `(let ((,iter-var (create-iter ,db ,opt))) - (unwind-protect (progn ,@body) - (destroy-iter ,iter-var)))) +(in-package :demo-db) diff -r 2015d7277629 -r 529419ac94f3 src/gen.rs --- a/src/gen.rs Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -//! demo -pub use fig::*; -pub use obj::*; -use std::ffi::{CStr, CString}; //OsStr,Path - //use std::os::unix::ffi::OsStrExt; -use std::slice; -use libc::{c_char,size_t}; - -#[macro_export] -macro_rules! cdefn { - (free $t:tt $n:tt) => { - #[no_mangle] - pub unsafe extern "C" fn $n(ptr: *mut $t) { - if ptr.is_null() { - return; - } - let _ = Box::from_raw(ptr); - } - }; - (from_string $t:tt $n:tt) => { - #[no_mangle] - pub unsafe extern "C" fn $n(ptr: *const c_char) -> *mut $t { - assert!(!ptr.is_null()); - let p = CStr::from_ptr(ptr).to_str().unwrap(); - Box::into_raw(Box::new(p.into())) - } - }; - (json_string $t:tt $r:tt $w:tt) => { - #[no_mangle] - pub unsafe extern "C" fn $r(ptr: *const c_char) -> *mut $t { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new($t::from_json_str(&s.to_str().unwrap()).unwrap())) - } - - #[no_mangle] - pub unsafe extern "C" fn $w(ptr: *const $t) -> *mut c_char { - let p = &*ptr; - let x = p.to_json_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() - } - }; - (ron_string $t:tt $r:tt $w:tt) => { - #[no_mangle] - pub unsafe extern "C" fn $r(ptr: *const c_char) -> *mut $t { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new($t::from_ron_str(&s.to_str().unwrap()).unwrap())) - } - - #[no_mangle] - pub unsafe extern "C" fn $w(ptr: *const $t) -> *mut c_char { - let p = &*ptr; - let x = p.to_ron_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() - } - }; - (bytes $t:tt $r:tt $w:tt) => { - #[no_mangle] - pub unsafe extern "C" fn $r(ptr: *const u8, len: size_t) -> *mut $t { - Box::into_raw(Box::new($t::decode(slice::from_raw_parts(ptr,len)).unwrap())) - } - - #[no_mangle] - pub unsafe extern "C" fn $w(ptr: *const $t) -> *mut u8 { - let p = &*ptr; - let mut x = p.encode().unwrap(); - let r = x.as_mut_ptr(); - std::mem::forget(x); - r - } - } -} - -cdefn!(free Service free_service); -cdefn!(from_string Service service_from_string); -cdefn!(json_string Service service_from_json_string service_to_json_string); -cdefn!(ron_string Service service_from_ron_string service_to_ron_string); -cdefn!(bytes Service service_decode service_encode); -cdefn!(free CustomService free_custom_service); -cdefn!(from_string CustomService custom_service_from_string); -cdefn!(json_string CustomService custom_service_from_json_string custom_service_to_json_string); -cdefn!(ron_string CustomService custom_service_from_ron_string custom_service_to_ron_string); -cdefn!(bytes CustomService custom_service_decode custom_service_encode); diff -r 2015d7277629 -r 529419ac94f3 src/lib.rs --- a/src/lib.rs Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -//! demo/lib.rs --- generated by DEMO:RS-MACROEXPAND -extern crate libc; -extern crate obj; -use libc::{c_char, size_t}; -use obj::{CustomService, Objective, Service}; -use std::ffi::{CStr, CString}; -use std::slice; -#[no_mangle] -pub unsafe extern "C" fn free_service(ptr: *mut Service) { - if ptr.is_null() { - return; - } - let _ = Box::from_raw(ptr); -} -#[no_mangle] -pub unsafe extern "C" fn service_from_string(ptr: *const c_char) -> *mut Service { - assert!(!ptr.is_null()); - let p = CStr::from_ptr(ptr).to_str().unwrap(); - Box::into_raw(Box::new(p.into())) -} -#[no_mangle] -pub unsafe extern "C" fn service_from_json_string(ptr: *const c_char) -> *mut Service { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new( - Service::from_json_str(&s.to_str().unwrap()).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn service_to_json_string(ptr: *const Service) -> *mut c_char { - let p = &*ptr; - let x = p.to_json_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() -} -#[no_mangle] -pub unsafe extern "C" fn service_from_ron_string(ptr: *const c_char) -> *mut Service { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new( - Service::from_ron_str(&s.to_str().unwrap()).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn service_to_ron_string(ptr: *const Service) -> *mut c_char { - let p = &*ptr; - let x = p.to_ron_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() -} -#[no_mangle] -pub unsafe extern "C" fn service_decode(ptr: *const u8, len: size_t) -> *mut Service { - Box::into_raw(Box::new( - Service::decode(slice::from_raw_parts(ptr, len)).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn service_encode(ptr: *const Service) -> *mut u8 { - let p = &*ptr; - let mut x = p.encode().unwrap(); - let r = x.as_mut_ptr(); - std::mem::forget(x); - r -} -#[no_mangle] -pub unsafe extern "C" fn free_custom_service(ptr: *mut CustomService) { - if ptr.is_null() { - return; - } - let _ = Box::from_raw(ptr); -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_from_string(ptr: *const c_char) -> *mut CustomService { - assert!(!ptr.is_null()); - let p = CStr::from_ptr(ptr).to_str().unwrap(); - Box::into_raw(Box::new(p.into())) -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_from_json_string(ptr: *const c_char) -> *mut CustomService { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new( - CustomService::from_json_str(&s.to_str().unwrap()).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_to_json_string(ptr: *const CustomService) -> *mut c_char { - let p = &*ptr; - let x = p.to_json_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_from_ron_string(ptr: *const c_char) -> *mut CustomService { - assert!(!ptr.is_null()); - let s = CStr::from_ptr(ptr); - Box::into_raw(Box::new( - CustomService::from_ron_str(&s.to_str().unwrap()).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_to_ron_string(ptr: *const CustomService) -> *mut c_char { - let p = &*ptr; - let x = p.to_ron_string().unwrap(); - CString::new(x.as_str().as_bytes()).unwrap().into_raw() -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_decode(ptr: *const u8, len: size_t) -> *mut CustomService { - Box::into_raw(Box::new( - CustomService::decode(slice::from_raw_parts(ptr, len)).unwrap(), - )) -} -#[no_mangle] -pub unsafe extern "C" fn custom_service_encode(ptr: *const CustomService) -> *mut u8 { - let p = &*ptr; - let mut x = p.encode().unwrap(); - let r = x.as_mut_ptr(); - std::mem::forget(x); - r -} diff -r 2015d7277629 -r 529419ac94f3 src/package.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/package.lisp Tue Jun 06 18:55:17 2023 -0400 @@ -0,0 +1,44 @@ +;; demo packages.lisp +(defpackage :demo-sys + (:nicknames :ds)) +(defpackage :demo-utils + (:use :demo-sys) + (:nicknames :dutils) + (:export + #:source-dir + #:random-id + #:scan-dir) + (:export + #:*cargo-target* + #:*rs-macros* + #:rs-defmacro + #:rs-macroexpand-1 + #:rs-macroexpand)) +(defpackage :demo-db + (:use :demo-sys) + (:nicknames :ddb)) +(defpackage :demo-ui + (:use :demo-sys) + (:nicknames :dui) + (:export + #:on-new-window + #:start-ui)) +(defpackage :demo-cli + (:use :demo-sys) + (:nicknames :dcli) + (:export + #:run-cli + #:demo-path + #:db-path + #:cli-opts + #:cli-handler + #:cli-cmd)) +(defpackage :demo + (:use #:cl #:demo-sys #:demo-utils #:demo-db #:demo-ui #:demo-cli) + (:nicknames :d) + (:local-nicknames + (#:v #:org.shirakumo.verbose) + (#:bt #:bordeaux-threads) + (#:cli #:clingon))) +(defpackage :demo-user + (:use :demo #:cl-user)) diff -r 2015d7277629 -r 529419ac94f3 src/packages.lisp --- a/src/packages.lisp Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -;; demo packages.lisp -(defpackage :demo-user - (:use :demo)) - -(defpackage :demo - (:use #:cl #:demo-ui #:demo-cli #:demo-tk #:demo-db) - (:local-nicknames - (#:v #:org.shirakumo.verbose) - (#:bt #:bordeaux-threads) - (#:cli #:clingon))) - -(defpackage :demo-ui - (:use) - (:export - #:on-new-window - #:start-ui)) -(defpackage :demo-tk - (:use) - (:export - #:source-dir - #:random-id - #:scan-dir - #:mkstr - #:symb - #:sbq-reader) - (:export - #:*cargo-target* - #:*rs-macros* - #:rs-defmacro - #:rs-macroexpand-1 - #:rs-macroexpand)) -(defpackage :demo-cli - (:use) - (:local-nick - (:export - #:run-cli - #:demo-path - #:db-path - #:cli-opts - #:cli-handler - #:cli-cmd)) -(defpackage :demo-db - (:use)) diff -r 2015d7277629 -r 529419ac94f3 src/tk/rs.lisp --- a/src/tk/rs.lisp Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -;;; RUST DSL - -;; So basically, this was born out of personal frustration with how -;; cbindgen and Rust macros work (they don't). Rust macros in general -;; are something of a pain in my opinion, so I thought why not just -;; generate Rust code from Lisp instead? - -(in-package :demo) - -(defvar *cargo-target* #p"/Users/ellis/dev/otom8/demo/target/") -(defvar *rs-macros* nil) - -;; TODO gensyms -(defmacro rs-defmacro (name args &body body) - "Define a macro which can be used within the body of a 'with-rs' form." - `(prog1 - (defmacro ,name ,@(mapcar #`(,a1) args) ,@body) - (push ',name *rs-macros*))) - -(defun rs-mod-form (crate &optional mods pub) - "Generate a basic mod form (CRATE . [MODS] [PUB])" - `(,crate ,mods ,pub)) - -(defmacro with-rs-env (imports &body body) - "Generate an environment for use within a Rust generator macro." - `(let ((imports ,(mapcar #'rs-mod-form imports))) - (format nil "~A~&~A" imports ',body))) - -(defun rs-use (crate &optional mods pub) - "Generate a single Rust use statement." - (concatenate - 'string - (if pub "pub " "") - "use " crate "::{" - (cond - ((consp mods) - (reduce - (lambda (x y) (format nil "~A,~A" x y)) - mods)) - (t mods)) - "};")) - -(defun rs-mod (mod &optional pub) - "Generate a single Rust mod statement." - (concatenate - 'string - (if pub "pub " "") - "mod " mod ";")) - -(defun rs-imports (&rest imports) - "Generate a string of Rust 'use' statements." - (cond - ((consp imports) - (mapcar (lambda (x) (apply #'rs-use (apply #'rs-mod-form x))) imports)) - (t imports))) - -(defmacro rs-extern-c-fn (name args &optional pub unsafe no-mangle &body body) - "Generate a Rust extern 'C' fn." - `(concatenate - 'string - ,(when no-mangle (format nil "#[no_mangle]~&")) - ,(when pub "pub ") - ,(when unsafe "unsafe ") - "extern \"C\" fn " ,name "(" - ,(cond - ((consp args) (reduce (lambda (x y) (format nil "~A,~A" x y)) args)) - (t args)) - ")" "{" ,@body "}")) - -(defun rs-obj-impl (obj) - "Implement Objective for give OBJ." - (format nil "impl Objective for ~A {};" obj)) - -;; (defun rs-macroexpand-1 (form &optional env)) - -;; (defun rs-macroexpand (env &rest body) - -;;; diff -r 2015d7277629 -r 529419ac94f3 src/tk/tk.lisp --- a/src/tk/tk.lisp Mon Jun 05 19:59:26 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -(in-package :demo) - -(defun mkstr (&rest args) - (with-output-to-string (s) - (dolist (a args) (princ a s)))) - -(defun symb (&rest args) - (values (intern (apply #'mkstr args)))) - -(defun random-id () - (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time))) - -(defun scan-dir (dir filename callback) - (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir))) - (funcall callback path))) - -(defun sbq-reader (stream sub-char numarg) - "The anaphoric sharp-backquote reader: #`((,a1))" - (declare (ignore sub-char)) - (unless numarg (setq numarg 1)) - `(lambda ,(loop for i from 1 to numarg - collect (symb 'a i)) - ,(funcall - (get-macro-character #\`) stream nil))) - -(eval-when (:load-toplevel) - (set-dispatch-macro-character - #\# #\` #'demo:sbq-reader)) diff -r 2015d7277629 -r 529419ac94f3 src/ui/ui.lisp --- a/src/ui/ui.lisp Mon Jun 05 19:59:26 2023 -0400 +++ b/src/ui/ui.lisp Tue Jun 06 18:55:17 2023 -0400 @@ -1,4 +1,4 @@ -(in-package :demo) +(in-package :demo-ui) (defparameter ui-server-port 8080) (defparameter ui-server-host "0.0.0.0") diff -r 2015d7277629 -r 529419ac94f3 src/utils/rs.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/utils/rs.lisp Tue Jun 06 18:55:17 2023 -0400 @@ -0,0 +1,78 @@ +;;; RUST DSL + +;; So basically, this was born out of personal frustration with how +;; cbindgen and Rust macros work (they don't). Rust macros in general +;; are something of a pain in my opinion, so I thought why not just +;; generate Rust code from Lisp instead? + +(in-package :demo-utils) + +(defvar *cargo-target* #p"/Users/ellis/dev/otom8/demo/target/") +(defvar *rs-macros* nil) + +;; TODO gensyms +(defmacro rs-defmacro (name args &body body) + "Define a macro which can be used within the body of a 'with-rs' form." + `(prog1 + (defmacro ,name ,@(mapcar #`(,a1) args) ,@body) + (push ',name *rs-macros*))) + +(defun rs-mod-form (crate &optional mods pub) + "Generate a basic mod form (CRATE . [MODS] [PUB])" + `(,crate ,mods ,pub)) + +(defmacro with-rs-env (imports &body body) + "Generate an environment for use within a Rust generator macro." + `(let ((imports ,(mapcar #'rs-mod-form imports))) + (format nil "~A~&~A" imports ',body))) + +(defun rs-use (crate &optional mods pub) + "Generate a single Rust use statement." + (concatenate + 'string + (if pub "pub " "") + "use " crate "::{" + (cond + ((consp mods) + (reduce + (lambda (x y) (format nil "~A,~A" x y)) + mods)) + (t mods)) + "};")) + +(defun rs-mod (mod &optional pub) + "Generate a single Rust mod statement." + (concatenate + 'string + (if pub "pub " "") + "mod " mod ";")) + +(defun rs-imports (&rest imports) + "Generate a string of Rust 'use' statements." + (cond + ((consp imports) + (mapcar (lambda (x) (apply #'rs-use (apply #'rs-mod-form x))) imports)) + (t imports))) + +(defmacro rs-extern-c-fn (name args &optional pub unsafe no-mangle &body body) + "Generate a Rust extern 'C' fn." + `(concatenate + 'string + ,(when no-mangle (format nil "#[no_mangle]~&")) + ,(when pub "pub ") + ,(when unsafe "unsafe ") + "extern \"C\" fn " ,name "(" + ,(cond + ((consp args) (reduce (lambda (x y) (format nil "~A,~A" x y)) args)) + (t args)) + ")" "{" ,@body "}")) + +(defun rs-obj-impl (obj) + "Implement Objective for give OBJ." + (format nil "impl Objective for ~A {};" obj)) + +;; (defun rs-macroexpand-1 (form &optional env)) + +;; (defun rs-macroexpand (env &rest body) + +;;; diff -r 2015d7277629 -r 529419ac94f3 src/utils/utils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/utils/utils.lisp Tue Jun 06 18:55:17 2023 -0400 @@ -0,0 +1,28 @@ +(in-package :demo-utils) + +(defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + +(defun symb (&rest args) + (values (intern (apply #'mkstr args)))) + +(defun random-id () + (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time))) + +(defun scan-dir (dir filename callback) + (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir))) + (funcall callback path))) + +(defun sbq-reader (stream sub-char numarg) + "The anaphoric sharp-backquote reader: #`((,a1))" + (declare (ignore sub-char)) + (unless numarg (setq numarg 1)) + `(lambda ,(loop for i from 1 to numarg + collect (symb 'a i)) + ,(funcall + (get-macro-character #\`) stream nil))) + +(eval-when (:load-toplevel) + (set-dispatch-macro-character + #\# #\` #'sbq-reader)) diff -r 2015d7277629 -r 529419ac94f3 tools/deps.sh --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/deps.sh Tue Jun 06 18:55:17 2023 -0400 @@ -0,0 +1,309 @@ +#!/usr/bin/sh +# install demo build dependencies +set -u +PKG_URL_ROOT="${PKG_URL_ROOT:-https://rwest.io/otom8/packy/bundle}" +PKG_NAME="demo_build_deps" +say() {printf 'babel-installer: %s\n' "$1"} +err() {say "$1" >&2; exit 1} +need_cmd() { + if ! check_cmd "$1"; then + err "need '$1' (command not found)" + fi} +check_cmd() {command -v "$1" > /dev/null 2>&1} +ensure() {if ! "$@"; then err "command failed: $*"; fi} +ignore() {"$@"} + +main () { + need_cmd chmod + need_cmd mkdir + need_cmd rm + + get_architecture || return 1 + local _arch="$RETVAL" + assert_nz "$_arch" "arch" + + # no extension unless on windows + local _ext="" + case "$_arch" in + *windows*) + _ext=".exe" + ;; + esac + + local _url="${PKG_URL_ROOT}/bin/dist/${_arch}/${PKG_NAME}${_ext}" + + local _dir + _dir="$(ensure mktemp -d)" + local _file="${_dir}/${PKG_NAME}${_ext}" + + local _ansi_escapes_are_valid=false + if [ -t 2 ]; then + if [ "${TERM+set}" = 'set' ]; then + case "$TERM" in + xterm*|rxvt*|urxvt*|linux*|vt*) + _ansi_escapes_are_valid=true + ;; + esac + fi + fi + + # check if we have to use /dev/tty to prompt the user + local need_tty=yes + for arg in "$@"; do + case "$arg" in + q) + # user wants to skip the prompt -- + # we don't need /dev/tty + need_tty=no + ;; + *) + ;; + esac + done + + if $_ansi_escapes_are_valid; then + printf "\33[1minfo:\33[0m downloading $PKG_NAME\n" 1>&2 + else + printf '%s\n' 'info: downloading $PKG_NAME' 1>&2 + fi + + ensure mkdir -p "$_dir" + ensure downloader "$_url" "$_file" "$_arch" + ensure chmod u+x "$_file" + if [ ! -x "$_file" ]; then + printf '%s\n' "Cannot execute $_file (likely because of mounting /tmp as noexec)." 1>&2 + printf '%s\n' "Please copy the file to a location where you can execute binaries and run ./${PKG_NAME}${_ext}." 1>&2 + exit 1 + fi + + if [ "$need_tty" = "yes" ]; then + # The installer is going to want to ask for confirmation by + # reading stdin. This script was piped into `sh` though and + # doesn't have stdin to pass to its children. Instead we're going + # to explicitly connect /dev/tty to the installer's stdin. + if [ ! -t 1 ]; then + err "Unable to run interactively. Run with -y to accept defaults" + fi + + ignore "$_file" "$@" < /dev/tty + else + ignore "$_file" "$@" + fi + + local _retval=$? + + ignore rm "$_file" + ignore rmdir "$_dir" + + return "$_retval" +} + +dl() { # curl || wget + local _dld + local _ciphersuites + local _err + local _status + if check_cmd curl; then + _dld=curl + elif check_cmd wget; then + _dld=wget + else + _dld='curl or wget' # to be used in error message of need_cmd + fi + + if [ "$1" = --check ]; then + need_cmd "$_dld" + elif [ "$_dld" = curl ]; then + get_ciphersuites_for_curl + _ciphersuites="$RETVAL" + if [ -n "$_ciphersuites" ]; then + _err=$(curl --proto '=https' --tlsv1.2 --ciphers "$_ciphersuites" --silent --show-error --fail --location "$1" --output "$2" 2>&1) + _status=$? + else + echo "Warning: Not enforcing strong cipher suites for TLS, this is potentially less secure" + if ! check_help_for "$3" curl --proto --tlsv1.2; then + echo "Warning: Not enforcing TLS v1.2, this is potentially less secure" + _err=$(curl --silent --show-error --fail --location "$1" --output "$2" 2>&1) + _status=$? + else + _err=$(curl --proto '=https' --tlsv1.2 --silent --show-error --fail --location "$1" --output "$2" 2>&1) + _status=$? + fi + fi + if [ -n "$_err" ]; then + echo "$_err" >&2 + if echo "$_err" | grep -q 404$; then + err "installer for platform '$3' not found 8^C - ask ellis to support your platform" + fi + fi + return $_status + elif [ "$_dld" = wget ]; then + get_ciphersuites_for_wget + _ciphersuites="$RETVAL" + if [ -n "$_ciphersuites" ]; then + _err=$(wget --https-only --secure-protocol=TLSv1_2 --ciphers "$_ciphersuites" "$1" -O "$2" 2>&1) + _status=$? + else + echo "Warning: Not enforcing strong cipher suites for TLS, this is potentially less secure" + if ! check_help_for "$3" wget --https-only --secure-protocol; then + echo "Warning: Not enforcing TLS v1.2, this is potentially less secure" + _err=$(wget "$1" -O "$2" 2>&1) + _status=$? + else + _err=$(wget --https-only --secure-protocol=TLSv1_2 "$1" -O "$2" 2>&1) + _status=$? + fi + fi + if [ -n "$_err" ]; then + echo "$_err" >&2 + if echo "$_err" | grep -q ' 404 Not Found$'; then + err "installer for platform '$3' not found!" + fi + fi + return $_status + else + err "Unknown downloader" # should not reach here + fi +} + +check_help_for() { + local _arch + local _cmd + local _arg + _arch="$1" + shift + _cmd="$1" + shift + + local _category + if "$_cmd" --help | grep -q 'For all options use the manual or "--help all".'; then + _category="all" + else + _category="" + fi + + case "$_arch" in + + *darwin*) + if check_cmd sw_vers; then + case $(sw_vers -productVersion) in + 10.*) + # If we're running on macOS, older than 10.13, then we always + # fail to find these options to force fallback + if [ "$(sw_vers -productVersion | cut -d. -f2)" -lt 13 ]; then + # Older than 10.13 + echo "Warning: Detected macOS platform older than 10.13" + return 1 + fi + ;; + 11.*) + # We assume Big Sur will be OK for now + ;; + *) + # Unknown product version, warn and continue + echo "Warning: Detected unknown macOS major version: $(sw_vers -productVersion)" + echo "Warning TLS capabilities detection may fail" + ;; + esac + fi + ;; + + esac + + for _arg in "$@"; do + if ! "$_cmd" --help $_category | grep -q -- "$_arg"; then + return 1 + fi + done + + true # not strictly needed +} + +# Return cipher suite string specified by user, otherwise return strong TLS 1.2-1.3 cipher suites +# if support by local tools is detected. Detection currently supports these curl backends: +# GnuTLS and OpenSSL (possibly also LibreSSL and BoringSSL). Return value can be empty. +get_ciphersuites_for_curl() { + if [ -n "${BABEL_TLS_CIPHERSUITES-}" ]; then + # user specified custom cipher suites, assume they know what they're doing + RETVAL="$BABEL_TLS_CIPHERSUITES" + return + fi + + local _openssl_syntax="no" + local _gnutls_syntax="no" + local _backend_supported="yes" + if curl -V | grep -q ' OpenSSL/'; then + _openssl_syntax="yes" + elif curl -V | grep -iq ' LibreSSL/'; then + _openssl_syntax="yes" + elif curl -V | grep -iq ' BoringSSL/'; then + _openssl_syntax="yes" + elif curl -V | grep -iq ' GnuTLS/'; then + _gnutls_syntax="yes" + else + _backend_supported="no" + fi + + local _args_supported="no" + if [ "$_backend_supported" = "yes" ]; then + # "unspecified" is for arch, allows for possibility old OS using macports, homebrew, etc. + if check_help_for "notspecified" "curl" "--tlsv1.2" "--ciphers" "--proto"; then + _args_supported="yes" + fi + fi + + local _cs="" + if [ "$_args_supported" = "yes" ]; then + if [ "$_openssl_syntax" = "yes" ]; then + _cs=$(get_strong_ciphersuites_for "openssl") + elif [ "$_gnutls_syntax" = "yes" ]; then + _cs=$(get_strong_ciphersuites_for "gnutls") + fi + fi + + RETVAL="$_cs" +} + +# Return cipher suite string specified by user, otherwise return strong TLS 1.2-1.3 cipher suites +# if support by local tools is detected. Detection currently supports these wget backends: +# GnuTLS and OpenSSL (possibly also LibreSSL and BoringSSL). Return value can be empty. +get_ciphersuites_for_wget() { + if [ -n "${BABEL_TLS_CIPHERSUITES-}" ]; then + # user specified custom cipher suites, assume they know what they're doing + RETVAL="$BABEL_TLS_CIPHERSUITES" + return + fi + + local _cs="" + if wget -V | grep -q '\-DHAVE_LIBSSL'; then + # "unspecified" is for arch, allows for possibility old OS using macports, homebrew, etc. + if check_help_for "notspecified" "wget" "TLSv1_2" "--ciphers" "--https-only" "--secure-protocol"; then + _cs=$(get_strong_ciphersuites_for "openssl") + fi + elif wget -V | grep -q '\-DHAVE_LIBGNUTLS'; then + # "unspecified" is for arch, allows for possibility old OS using macports, homebrew, etc. + if check_help_for "notspecified" "wget" "TLSv1_2" "--ciphers" "--https-only" "--secure-protocol"; then + _cs=$(get_strong_ciphersuites_for "gnutls") + fi + fi + + RETVAL="$_cs" +} + +# Return strong TLS 1.2-1.3 cipher suites in OpenSSL or GnuTLS syntax. TLS 1.2 +# excludes non-ECDHE and non-AEAD cipher suites. DHE is excluded due to bad +# DH params often found on servers (see RFC 7919). Sequence matches or is +# similar to Firefox 68 ESR with weak cipher suites disabled via about:config. +# $1 must be openssl or gnutls. +get_strong_ciphersuites_for() { + if [ "$1" = "openssl" ]; then + # OpenSSL is forgiving of unknown values, no problems with TLS 1.3 values on versions that don't support it yet. + echo "TLS_AES_128_GCM_SHA256:TLS_CHACHA20_POLY1305_SHA256:TLS_AES_256_GCM_SHA384:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384" + elif [ "$1" = "gnutls" ]; then + # GnuTLS isn't forgiving of unknown values, so this may require a GnuTLS version that supports TLS 1.3 even if wget doesn't. + # Begin with SECURE128 (and higher) then remove/add to build cipher suites. Produces same 9 cipher suites as OpenSSL but in slightly different order. + echo "SECURE128:-VERS-SSL3.0:-VERS-TLS1.0:-VERS-TLS1.1:-VERS-DTLS-ALL:-CIPHER-ALL:-MAC-ALL:-KX-ALL:+AEAD:+ECDHE-ECDSA:+ECDHE-RSA:+AES-128-GCM:+CHACHA20-POLY1305:+AES-256-GCM" + fi +} + +main "$@" || exit 1