# HG changeset patch # User Richard Westhaver # Date 1718590504 14400 # Node ID 81b7333f27f885ca4be61998462cd112e1d3116f # Parent 6b652d7d66637966f064071d28ff865297d4deaf more examples diff -r 6b652d7d6663 -r 81b7333f27f8 default.sxp --- a/default.sxp Sun Apr 14 20:48:05 2024 -0400 +++ b/default.sxp Sun Jun 16 22:15:04 2024 -0400 @@ -1,1 +1,1 @@ -;; demo user configuration file \ No newline at end of file +;; demo application config diff -r 6b652d7d6663 -r 81b7333f27f8 docs/notes.org --- a/docs/notes.org Sun Apr 14 20:48:05 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -* ideas -** use branches for separate levels of expansion -- or perhaps some other VC feature.. although I don't want any - parallel to time, as if expansions occur in sequence. Thus things - like tags don't feel quite right. -* research -for libraries, always prefer [[https://common-lisp-libraries.readthedocs.io/][defacto libs]] -** [[https://github.com/screenshotbot/screenshotbot-oss][screenshotbot-oss]] -- monolithic repo, includes third-party dependencies - - full quicklisp source - - asdf, etc -- addresses many of my concerns about running CL in prod -- the repo is too heavy for my liking though -- I do like the idea of having many systems though -** DB -*** CLIENT -**** [[https://github.com/fukamachi/mito][mito]] -ORM, sqlite, postgres, mysql support -**** [[https://github.com/fukamachi/cl-dbi][cl-dbi]] -database independent interface -**** [[https://github.com/fukamachi/sxql][sxql]] -SQL generator -*** SERVICE -**** [[https://github.com/launchbadge/sqlx][sqlx]] -- supports rustls, tokio -- we should write the service queries using a common-lisp DSL! - #+begin_src toml - sqlx = { version = "0.7", features = [ "runtime-tokio", "tls-rustls", "any", "chrono" ] } - #+end_src -** LOGGING -*** CLIENT -**** [[https://github.com/sharplispers/log4cl/][log4cl]] -supports slime well -*** SERVICE -**** [[https://crates.io/crates/tracing][tracing]] -**** [[https://crates.io/crates/tokio-console][tokio-console]] - monitoring tool -works with tracing using the [[https://crates.io/crates/console-subscriber][console-subscriber]] crate -** UI -[[https://mcclim.common-lisp.dev/][mcclim]] -[[https://slint-ui.com/][slint-ui]] -[[https://github.com/rabbibotton/clog][clog]] diff -r 6b652d7d6663 -r 81b7333f27f8 examples/app/mpk.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/app/mpk.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,23 @@ +;;; examples/app/mpk.lisp --- MPK demo + +;; + +;;; Code: +(in-package :user) +(defpkg mpk (:use :cl :std :dat :net :obj :log :rdb :packy)) +(in-package :mpk) + +(defvar *mpc*) + +(defun mpc-init () + (let* ((conn (mpd:connect)) + (status (mpd:status conn))) + (setq mpk::*mpc* conn) + (format t "mpd state: ~A~%" (mpd:state conn)) + (values conn status))) + +(defun play () (mpd:play *mpc*)) +(defun stop () (mpd:stop *mpc*)) +(defun pause () (mpd:pause *mpc*)) + +#+nil (mpc-init) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/mbdb.lisp --- a/examples/db/mbdb.lisp Sun Apr 14 20:48:05 2024 -0400 +++ b/examples/db/mbdb.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -1,15 +1,29 @@ ;;; examples/mbdb.lisp --- MusicBrainz Database import and analysis -;; This example show how to migrate a set of complex JSON objects to -;; RocksDB using a dump from the MusicBrainz database +;; This example show how to migrate a set of complex JSON objects and +;; SQL dumps to RocksDB using data from the MusicBrainz database ;; (https://musicbrainz.org/). The files are hosted at -;; https://packy.compiler.company/data/mbdump +;; https://packy.compiler.company/data + +;;; Commentary: + +;; The original data is located here: +;; https://data.metabrainz.org/pub/musicbrainz/data/ -;; we parse some of the database schema from the sql files here: +;; The actual json dumps are quite large (releas.json is 208Gb!), so +;; we provide our own trimmed down sampling. Each file is sampled +;; randomly and individually, so actual linkage data is totally +;; clobbered. If you want to work do some OLAP stuff you will need the +;; full data set which is packaged as mbdump-full.tar.zst. + +;; the data prep script is located at ../mbdump-prep.lisp + +;; we parsed some of the database schema from the sql files here: ;; https://github.com/metabrainz/musicbrainz-server/tree/master/admin/sql ;;; Code: -(defpackage :examples/mbdb +(in-package :std-user) +(defpkg :examples/mbdb (:use :cl :std :dat/json :net/fetch :obj/id :rdb :cli/clap :obj/uuid :sb-concurrency :log :dat/csv :dat/proto :sb-thread) (:import-from :obj/uuid :make-uuid-from-string) @@ -51,7 +65,7 @@ "The oracle assigned to the mbdb system, which should usually be the current thread.") (declaim (task-pool *mbdb-tasks*)) -(defvar *mbdb-tasks* (make-task-pool :oracle *mbdb-oracle*) +(defvar *mbdb-tasks* (make-task-pool :oracle-id (oracle-id *mbdb-oracle*)) "The mbdb task pool. This object holds a queue of jobs which are dispatched to workers. Results are collected and processed by the oracle.") @@ -66,11 +80,12 @@ (defvar *mbdump-pack-url* "https://packy.compiler.company/data/mbdump.tar.zst" "Remote locaton of MusicBrainz JSON dump pack.") +(defvar *mbdb-worker-dir* (merge-pathnames ".import/" *mbdb-path*)) + (defvar *mbdump-pack* (merge-pathnames "mbdump.tar.zst" *mbdb-worker-dir*)) + (defvar *mbsamp-pack* (merge-pathnames "mbsamp.tar.zst" *mbdb-worker-dir*)) -(defvar *mbdb-worker-dir* (merge-pathnames ".import/" *mbdb-path*)) - (defvar *mbdump-files* nil) ;; set by MBDB-UNPACK (defvar *mbsamp-files* nil) ;; set by MBDB-UNPACK @@ -112,6 +127,8 @@ #+nil (extract-mbsamp (car (mbsamp-fetch))) ;;; Parsing + +;;;; MBSamp (define-constant +mbsamp-null+ "\\N" :test #'string=) (defun nullable (str) @@ -208,14 +225,6 @@ (when file (dat/csv:read-csv-file file :header nil :delimiter #\Tab :map-fns map-fns)))) -(defun extract-mbdump-file (file) - "Extract the contents of a json-dump FILE. Return a json-object." - (with-open-file (f file) - ;; (sb-impl::with-array-data - (loop for x = (json-read f nil) - while x - collect x))) - (defmacro with-mbsamp-proc (table shape &body vals) (with-gensyms (row i) `(coerce @@ -258,6 +267,15 @@ (def-mbsamp-proc release 0 1 2 13) (def-mbsamp-proc instrument 0 1 2 5 7) +;;;; MBDump +(defun extract-mbdump-file (file) + "Extract the contents of a json-dump FILE. Return a json-object." + (with-open-file (f file) + ;; (sb-impl::with-array-data + (loop for x = (json-read f nil) + while x + collect x))) + (defun extract-mbdump-columns (obj) "Extract fields from a json-object, returning a vector of uninitialized column-families which can be created with #'create-cfs. @@ -274,6 +292,8 @@ (defclass mbdb-task (task) ()) +(defclass mbdb-stage (stage) ()) + ;;; Main (defmain () (let ((*default-pathname-defaults* *mbdb-path*) @@ -281,17 +301,27 @@ (*csv-separator* #\Tab) (*cpus* (num-cpus)) (*log-timestamp* nil) - (*log-level* :warn)) + (*log-level* :info)) (log:info! "Welcome to MBDB") (ensure-directories-exist *mbdb-worker-dir* :verbose t) ;; prepare workers - (setf *mbdb-oracle* (make-oracle sb-thread:*current-thread*) - *mbdb-tasks* (make-task-pool :oracle *mbdb-oracle*)) - (push-worker (sb-thread:make-thread #'mbsamp-fetch) *mbdb-tasks*) + (setq *mbdb-oracle* (make-oracle sb-thread:*current-thread*)) + (setq *mbdb-tasks* (make-task-pool :oracle-id (oracle-id *mbdb-oracle*))) + ;; (make-workers + ;; (push-worker (make-thread #'?) *mbdb-tasks*) + ;; (with-tasks ()) - (let ((job (make-job))) - (push-task (make-instance 'mbdb-task :object #'mbsamp-fetch) job)) + ;; fetch + (let ((job (make-job (make-array 2 :fill-pointer 0 :initial-element (make-task) :element-type 'task)))) + (push-task (make-task #'mbsamp-fetch) job) + (push-task (make-task #'mbdump-fetch) job) + (push-job job *mbdb-tasks*)) + ;; unpack + (let ((job (make-job (make-array 2 :fill-pointer 0 :initial-element (make-task) :element-type 'task)))) + (push-task (make-task #'mbsamp-unpack) job) + (push-task (make-task #'mbdump-unpack) job) + (push-job job *mbdb-tasks*)) ;; (sb-thread:make-thread #'mbsamp-fetch) ;; prepare column family data @@ -300,16 +330,16 @@ (with-db (db *mbdb*) (open-db db) (setf (rdb-cfs db) *mbsamp-cfs*) - ;; (create-cfs db) - (log:info! "database initialized") - ;; - (close-db db)) - + (backfill-opts db) + (log:info! "database initialized")) ;; launch tasks ;; wait - (wait-for-threads (task-pool-workers *mbdb-tasks*)) - ;; summarize - (info! "mbdb stats" (print-stats *mbdb*)) - ;; close - )) + (unwind-protect + (progn + (wait-for-threads (task-pool-workers *mbdb-tasks*)) + ;; summarize + (when-let ((stats (print-stats *mbdb*))) (info! "mbdb stats" stats))) + ;; close + (close-db *mbdb*)))) + diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/disk.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/disk.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,838 @@ +(in-package :xdb) +;;; Disk +(defclass collection () + ((name :initarg :name + :accessor name) + (path :initarg :path + :accessor path) + (docs :initarg :docs + :accessor docs) + (packages :initform (make-s-packages) + :accessor packages) + (classes :initform (make-class-cache) + :accessor classes) + (last-id :initform 0 + :accessor last-id) + (object-cache :initarg :object-cache + :initform (make-hash-table :size 1000 + :test 'eq) + :accessor object-cache) + (id-cache :initarg :id-cache + :initform (make-hash-table :size 1000) + :accessor id-cache))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *codes* + #(ascii-string + id + cons + string + null + storable-class + storable-object + standard-class + standard-object + standard-link + fixnum + bignum + ratio + double-float + single-float + complex + symbol + intern-package-and-symbol + intern-symbol + character + simple-vector + array + hash-table + pathname + collection))) + +(defvar *statistics* ()) +(defun collect-stats (code) + (let* ((type (aref *codes* code)) + (cons (assoc type *statistics*))) + (if cons + (incf (cdr cons)) + (push (cons type 1) *statistics*)) + type)) + +(defvar *collection* nil) + +(defvar *classes*) +(defvar *packages*) +(declaim (vector *classes* *packages*)) + +(defvar *indexes*) +(declaim (hash-table *indexes*)) + +(defvar *written-objects*) +(declaim (hash-table *indexes*)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun type-code (type) + (position type *codes*))) + +(defparameter *readers* (make-array (length *codes*))) +(declaim (type (simple-array function (*)) *readers*)) + +(defmacro defreader (type (stream) &body body) + (let ((name (intern (format nil "~a-~a" type '#:reader)))) + `(progn + (defun ,name (,stream) + ,@body) + (setf (aref *readers* ,(type-code type)) + #',name)))) + +(declaim (inline call-reader)) +(defun call-reader (code stream) + ;; (collect-stats code) + (funcall (aref *readers* code) stream)) + +(defconstant +sequence-length+ 2) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +fixnum-length+ 4)) +(defconstant +char-length+ 2) +(defconstant +id-length+ 4) +(defconstant +class-id-length+ 2) +(defconstant +hash-table-length+ 3) + +(defconstant +unbound-slot+ 254) +(defconstant +end+ 255) + +(defconstant +ascii-char-limit+ (code-char 128)) + +(deftype ascii-string () + '(or + #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255 + (satisfies ascii-string-p))) + +(defun ascii-string-p (string) + (declare (simple-string string)) + (loop for char across string + always (char< char +ascii-char-limit+))) + +(deftype storage-fixnum () + `(signed-byte ,(* +fixnum-length+ 8))) + +(defun make-class-cache () + (make-array 10 :adjustable t :fill-pointer 0)) + +(defmacro with-collection (collection &body body) + (let ((collection-sym (gensym))) + `(let* ((,collection-sym ,collection) + (*collection* ,collection-sym) + (*packages* (packages ,collection-sym)) + (*classes* (classes ,collection-sym)) + (*indexes* (id-cache ,collection-sym))) + ,@body))) + +;;; +(defun slot-effective-definition (class slot-name) + (find slot-name (class-slots class) :key #'slot-definition-name)) + +(defun dump-data (stream) + (map-docs + nil + (lambda (document) + (write-top-level-object document stream)) + *collection*)) + +(defun write-top-level-object (object stream) + (if (typep object 'id) + (write-storable-object object stream) + (write-object object stream))) + +(declaim (inline read-next-object)) +(defun read-next-object (stream) + (call-reader (read-n-bytes 1 stream) stream)) + +;;; NIL + +(defmethod write-object ((object null) stream) + (write-n-bytes #.(type-code 'null) 1 stream)) + +(defreader null (stream) + (declare (ignore stream)) + nil) + +;;; Symbol + +(defun make-s-packages () + (make-array 10 :adjustable t :fill-pointer 0)) + +(defun make-s-package (package) + (let ((symbols (make-array 100 :adjustable t :fill-pointer 0))) + (values (vector-push-extend (cons package symbols) *packages*) + symbols + t))) + +(defun find-s-package (package) + (loop for i below (length *packages*) + for (stored-package . symbols) = (aref *packages* i) + when (eq package stored-package) + return (values i symbols) + finally (return (make-s-package package)))) + +(defun s-intern (symbol) + (multiple-value-bind (package-id symbols new-package) + (find-s-package (symbol-package symbol)) + (let* ((existing (and (not new-package) + (position symbol symbols))) + (symbol-id (or existing + (vector-push-extend symbol symbols)))) + (values package-id symbol-id new-package (not existing))))) + +(defun s-intern-existing (symbol symbols) + (vector-push-extend symbol symbols)) + +(defmethod write-object ((symbol symbol) stream) + (multiple-value-bind (package-id symbol-id + new-package new-symbol) + (s-intern symbol) + (cond ((and new-package new-symbol) + (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream) + (write-object (package-name (symbol-package symbol)) stream) + (write-object (symbol-name symbol) stream)) + (new-symbol + (write-n-bytes #.(type-code 'intern-symbol) 1 stream) + (write-n-bytes package-id +sequence-length+ stream) + (write-object (symbol-name symbol) stream)) + (t + (write-n-bytes #.(type-code 'symbol) 1 stream) + (write-n-bytes package-id +sequence-length+ stream) + (write-n-bytes symbol-id +sequence-length+ stream))))) + +(defreader symbol (stream) + (let* ((package-id (read-n-bytes +sequence-length+ stream)) + (symbol-id (read-n-bytes +sequence-length+ stream)) + (package (or (aref *packages* package-id) + (error "Package with id ~a not found" package-id))) + (symbol (aref (cdr package) symbol-id))) + (or symbol + (error "Symbol with id ~a in package ~a not found" + symbol-id (car package))))) + +(defreader intern-package-and-symbol (stream) + (let* ((package-name (read-next-object stream)) + (symbol-name (read-next-object stream)) + (package (or (find-package package-name) + (error "Package ~a not found" package-name))) + (symbol (intern symbol-name package)) + (s-package (nth-value 1 (make-s-package package)))) + (s-intern-existing symbol s-package) + symbol)) + +(defreader intern-symbol (stream) + (let* ((package-id (read-n-bytes +sequence-length+ stream)) + (symbol-name (read-next-object stream)) + (package (or (aref *packages* package-id) + (error "Package with id ~a for symbol ~a not found" + package-id symbol-name))) + (symbol (intern symbol-name (car package)))) + (s-intern-existing symbol (cdr package)) + symbol)) + +;;; Integer + +(declaim (inline sign)) +(defun sign (n) + (if (minusp n) + 1 + 0)) + +(defun write-fixnum (n stream) + (declare (storage-fixnum n)) + (write-n-bytes #.(type-code 'fixnum) 1 stream) + (write-n-signed-bytes n +fixnum-length+ stream)) + +(defun write-bignum (n stream) + (declare ((and integer (not storage-fixnum)) n)) + (write-n-bytes #.(type-code 'bignum) 1 stream) + (write-n-bytes (sign n) 1 stream) + (let* ((fixnum-bits (* +fixnum-length+ 8)) + (n (abs n)) + (size (ceiling (integer-length n) fixnum-bits))) + (write-n-bytes size 1 stream) + (loop for position by fixnum-bits below (* size fixnum-bits) + do + (write-n-bytes (ldb (byte fixnum-bits position) n) + +fixnum-length+ stream)))) + +(defmethod write-object ((object integer) stream) + (typecase object + (storage-fixnum + (write-fixnum object stream)) + (t (write-bignum object stream)))) + +(declaim (inline read-sign)) +(defun read-sign (stream) + (if (plusp (read-n-bytes 1 stream)) + -1 + 1)) + +(defreader bignum (stream) + (let ((fixnum-bits (* +fixnum-length+ 8)) + (sign (read-sign stream)) + (size (read-n-bytes 1 stream)) + (integer 0)) + (loop for position by fixnum-bits below (* size fixnum-bits) + do + (setf (ldb (byte fixnum-bits position) integer) + (read-n-bytes +fixnum-length+ stream))) + (* sign integer))) + +(defreader fixnum (stream) + (read-n-signed-bytes +fixnum-length+ stream)) + +;;; Ratio + +(defmethod write-object ((object ratio) stream) + (write-n-bytes #.(type-code 'ratio) 1 stream) + (write-object (numerator object) stream) + (write-object (denominator object) stream)) + +(defreader ratio (stream) + (/ (read-next-object stream) + (read-next-object stream))) + +;;; Float + +(defun write-8-bytes (n stream) + (write-n-bytes (ldb (byte 32 0) n) 4 stream) + (write-n-bytes (ldb (byte 64 32) n) 4 stream)) + +(defun read-8-bytes (stream) + (logior (read-n-bytes 4 stream) + (ash (read-n-bytes 4 stream) 32))) + +(defmethod write-object ((float float) stream) + (etypecase float + (single-float + (write-n-bytes #.(type-code 'single-float) 1 stream) + (write-n-bytes (encode-float32 float) 4 stream)) + (double-float + (write-n-bytes #.(type-code 'double-float) 1 stream) + (write-8-bytes (encode-float64 float) stream)))) + +(defreader single-float (stream) + (decode-float32 (read-n-bytes 4 stream))) + +(defreader double-float (stream) + (decode-float64 (read-8-bytes stream))) + +;;; Complex + +(defmethod write-object ((complex complex) stream) + (write-n-bytes #.(type-code 'complex) 1 stream) + (write-object (realpart complex) stream) + (write-object (imagpart complex) stream)) + +(defreader complex (stream) + (complex (read-next-object stream) + (read-next-object stream))) + +;;; Characters + +(defmethod write-object ((character character) stream) + (write-n-bytes #.(type-code 'character) 1 stream) + (write-n-bytes (char-code character) +char-length+ stream)) + +(defreader character (stream) + (code-char (read-n-bytes +char-length+ stream))) + +;;; Strings + +(defun write-ascii-string (string stream) + (declare (simple-string string)) + (loop for char across string + do (write-n-bytes (char-code char) 1 stream))) + +(defun write-multibyte-string (string stream) + (declare (simple-string string)) + (loop for char across string + do (write-n-bytes (char-code char) +char-length+ stream))) + +(defmethod write-object ((string string) stream) + (etypecase string + ((not simple-string) + (call-next-method)) + #+sb-unicode + (simple-base-string + (write-n-bytes #.(type-code 'ascii-string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-ascii-string string stream)) + (ascii-string + (write-n-bytes #.(type-code 'ascii-string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-ascii-string string stream)) + (string + (write-n-bytes #.(type-code 'string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-multibyte-string string stream)))) + +(declaim (inline read-ascii-string)) +(defun read-ascii-string (length stream) + (let ((string (make-string length :element-type 'base-char))) + ;#-sbcl + (loop for i below length + do (setf (schar string i) + (code-char (read-n-bytes 1 stream)))) + #+(and nil sbcl (or x86 x86-64)) + (read-ascii-string-optimized length string stream) + string)) + +(defreader ascii-string (stream) + (read-ascii-string (read-n-bytes +sequence-length+ stream) stream)) + +(defreader string (stream) + (let* ((length (read-n-bytes +sequence-length+ stream)) + (string (make-string length :element-type 'character))) + (loop for i below length + do (setf (schar string i) + (code-char (read-n-bytes +char-length+ stream)))) + string)) + +;;; Pathname + +(defmethod write-object ((pathname pathname) stream) + (write-n-bytes #.(type-code 'pathname) 1 stream) + (write-object (pathname-name pathname) stream) + (write-object (pathname-directory pathname) stream) + (write-object (pathname-device pathname) stream) + (write-object (pathname-type pathname) stream) + (write-object (pathname-version pathname) stream)) + +(defreader pathname (stream) + (make-pathname + :name (read-next-object stream) + :directory (read-next-object stream) + :device (read-next-object stream) + :type (read-next-object stream) + :version (read-next-object stream))) + +;;; Cons + +(defmethod write-object ((list cons) stream) + (cond ((circular-list-p list) + (error "Can't store circular lists")) + (t + (write-n-bytes #.(type-code 'cons) 1 stream) + (loop for cdr = list then (cdr cdr) + do + (cond ((consp cdr) + (write-object (car cdr) stream)) + (t + (write-n-bytes +end+ 1 stream) + (write-object cdr stream) + (return))))))) + +(defreader cons (stream) + (let ((first-cons (list (read-next-object stream)))) + (loop for previous-cons = first-cons then new-cons + for car = (let ((id (read-n-bytes 1 stream))) + (cond ((eq id +end+) + (setf (cdr previous-cons) (read-next-object stream)) + (return)) + ((call-reader id stream)))) + for new-cons = (list car) + do (setf (cdr previous-cons) new-cons)) + first-cons)) + +;;; Simple-vector + +(defmethod write-object ((vector vector) stream) + (typecase vector + (simple-vector + (write-simple-vector vector stream)) + (t + (call-next-method)))) + +(defun write-simple-vector (vector stream) + (declare (simple-vector vector)) + (write-n-bytes #.(type-code 'simple-vector) 1 stream) + (write-n-bytes (length vector) +sequence-length+ stream) + (loop for elt across vector + do (write-object elt stream))) + +(defreader simple-vector (stream) + (let ((vector (make-array (read-n-bytes +sequence-length+ stream)))) + (loop for i below (length vector) + do (setf (svref vector i) (read-next-object stream))) + vector)) + +;;; Array + +(defun boolify (x) + (if x + 1 + 0)) + +(defmethod write-object ((array array) stream) + (write-n-bytes #.(type-code 'array) 1 stream) + (write-object (array-dimensions array) stream) + (cond ((array-has-fill-pointer-p array) + (write-n-bytes 1 1 stream) + (write-n-bytes (fill-pointer array) +sequence-length+ stream)) + (t + (write-n-bytes 0 2 stream))) + (write-object (array-element-type array) stream) + (write-n-bytes (boolify (adjustable-array-p array)) 1 stream) + (loop for i below (array-total-size array) + do (write-object (row-major-aref array i) stream))) + +(defun read-array-fill-pointer (stream) + (if (plusp (read-n-bytes 1 stream)) + (read-n-bytes +sequence-length+ stream) + (not (read-n-bytes 1 stream)))) + +(defreader array (stream) + (let ((array (make-array (read-next-object stream) + :fill-pointer (read-array-fill-pointer stream) + :element-type (read-next-object stream) + :adjustable (plusp (read-n-bytes 1 stream))))) + (loop for i below (array-total-size array) + do (setf (row-major-aref array i) (read-next-object stream))) + array)) + +;;; Hash-table + +(defvar *hash-table-tests* #(eql equal equalp eq)) +(declaim (simple-vector *hash-table-tests*)) + +(defun check-hash-table-test (hash-table) + (let* ((test (hash-table-test hash-table)) + (test-id (position test *hash-table-tests*))) + (unless test-id + (error "Only standard hashtable tests are supported, ~a has ~a" + hash-table test)) + test-id)) + +(defmethod write-object ((hash-table hash-table) stream) + (write-n-bytes #.(type-code 'hash-table) 1 stream) + (write-n-bytes (check-hash-table-test hash-table) 1 stream) + (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream) + (loop for key being the hash-keys of hash-table + using (hash-value value) + do + (write-object key stream) + (write-object value stream)) + (write-n-bytes +end+ 1 stream)) + +(defreader hash-table (stream) + (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream))) + (size (read-n-bytes +hash-table-length+ stream)) + (table (make-hash-table :test test :size size))) + (loop for id = (read-n-bytes 1 stream) + until (eq id +end+) + do (setf (gethash (call-reader id stream) table) + (read-next-object stream))) + table)) + +;;; storable-class + +(defun cache-class (class id) + (when (< (length *classes*) id) + (adjust-array *classes* (1+ id))) + (when (> (1+ id) (fill-pointer *classes*)) + (setf (fill-pointer *classes*) (1+ id))) + (setf (aref *classes* id) class)) + +(defmethod write-object ((class storable-class) stream) + (cond ((position class *classes* :test #'eq)) + (t + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((id (vector-push-extend class *classes*)) + (slots (slots-to-store class))) + (write-n-bytes #.(type-code 'storable-class) 1 stream) + (write-object (class-name class) stream) + (write-n-bytes id +class-id-length+ stream) + (write-n-bytes (length slots) +sequence-length+ stream) + (loop for slot across slots + do (write-object (slot-definition-name slot) + stream)) + id)))) + +(defreader storable-class (stream) + (let ((class (find-class (read-next-object stream)))) + (cache-class class + (read-n-bytes +class-id-length+ stream)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((length (read-n-bytes +sequence-length+ stream)) + (vector (make-array length))) + (loop for i below length + for slot-d = + (slot-effective-definition class (read-next-object stream)) + when slot-d + do (setf (aref vector i) + (cons (slot-definition-location slot-d) + (slot-definition-initform slot-d)))) + (setf (slot-locations-and-initforms class) vector)) + (read-next-object stream))) + +;;; Storable ID + +(defmethod write-object ((object id) stream) + (cond ((written object) + (let* ((class (class-of object)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'id) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (id object) +id-length+ stream))) + (t + (write-storable-object object stream)))) + +(defun get-class (id) + (aref *classes* id)) + +(declaim (inline get-instance)) +(defun get-instance (class-id id) + (let* ((class (get-class class-id)) + (index (if (typep class 'storable-class) + (id-cache class) + *indexes*))) + (or (gethash id index) + (setf (gethash id index) + (fast-allocate-instance class))))) + +(defreader id (stream) + (get-instance (read-n-bytes +class-id-length+ stream) + (read-n-bytes +id-length+ stream))) + +;;; storable-object +;; Can't use write-object method, because it would conflict with +;; writing a pointer to a standard object +(defun write-storable-object (object stream) + (let* ((class (class-of object)) + (slots (slot-locations-and-initforms class)) + (class-id (write-object class stream))) + (declare (simple-vector slots)) + (write-n-bytes #.(type-code 'storable-object) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (unless (id object) + (setf (id object) (last-id *collection*)) + (incf (last-id *collection*))) + (write-n-bytes (id object) +id-length+ stream) + (setf (written object) t) + (loop for id below (length slots) + for (location . initform) = (aref slots id) + for value = (standard-instance-access object location) + unless (eql value initform) + do + (write-n-bytes id 1 stream) + (if (eq value '+slot-unbound+) + (write-n-bytes +unbound-slot+ 1 stream) + (write-object value stream))) + (write-n-bytes +end+ 1 stream))) + +(defreader storable-object (stream) + (let* ((class-id (read-n-bytes +class-id-length+ stream)) + (id (read-n-bytes +id-length+ stream)) + (instance (get-instance class-id id)) + (class (class-of instance)) + (slots (slot-locations-and-initforms class))) + (declare (simple-vector slots)) + (setf (id instance) id) + (if (>= id (last-id *collection*)) + (setf (last-id *collection*) (1+ id))) + (loop for slot-id = (read-n-bytes 1 stream) + until (= slot-id +end+) + do + (setf (standard-instance-access instance + (car (aref slots slot-id))) + (let ((code (read-n-bytes 1 stream))) + (if (= code +unbound-slot+) + '+slot-unbound+ + (call-reader code stream))))) + instance)) + +;;; standard-class + +(defmethod write-object ((class standard-class) stream) + (cond ((position class *classes* :test #'eq)) + (t + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((id (vector-push-extend class *classes*)) + (slots (class-slots class))) + (write-n-bytes #.(type-code 'standard-class) 1 stream) + (write-object (class-name class) stream) + (write-n-bytes id +class-id-length+ stream) + (write-n-bytes (length slots) +sequence-length+ stream) + (loop for slot in slots + do (write-object (slot-definition-name slot) + stream)) + id)))) + +(defreader standard-class (stream) + (let ((class (find-class (read-next-object stream)))) + (cache-class class + (read-n-bytes +class-id-length+ stream)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((length (read-n-bytes +sequence-length+ stream))) + (loop for i below length + do (slot-effective-definition class (read-next-object stream)) + ;;do (setf (aref vector i) + ;; (cons (slot-definition-location slot-d) + ;; (slot-definition-initform slot-d))) + )) + (read-next-object stream))) + +;;; standard-link + +(defun write-standard-link (object stream) + (let* ((class (class-of object)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'standard-link) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (get-object-id object) +id-length+ stream))) + +(defreader standard-link (stream) + (get-instance (read-n-bytes +class-id-length+ stream) + (read-n-bytes +id-length+ stream))) + +;;; standard-object + +(defun get-object-id (object) + (let ((cache (object-cache *collection*))) + (or (gethash object cache) + (prog1 + (setf (gethash object cache) + (last-id *collection*)) + (incf (last-id *collection*)))))) + +(defmethod write-object ((object standard-object) stream) + (if (gethash object *written-objects*) + (write-standard-link object stream) + (let* ((class (class-of object)) + (slots (class-slots class)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'standard-object) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (get-object-id object) +id-length+ stream) + (setf (gethash object *written-objects*) t) + (loop for id from 0 + for slot in slots + for location = (slot-definition-location slot) + for initform = (slot-definition-initform slot) + for value = (standard-instance-access object location) + do + (write-n-bytes id 1 stream) + (if (eq value '+slot-unbound+) + (write-n-bytes +unbound-slot+ 1 stream) + (write-object value stream))) + (write-n-bytes +end+ 1 stream)))) + +(defreader standard-object (stream) + (let* ((class-id (read-n-bytes +class-id-length+ stream)) + (id (read-n-bytes +id-length+ stream)) + (instance (get-instance class-id id)) + (class (class-of instance)) + (slots (class-slots class))) + (flet ((read-slot () + (let ((code (read-n-bytes 1 stream))) + (if (= code +unbound-slot+) + '+slot-unbound+ + (call-reader code stream))))) + (loop for slot-id = (read-n-bytes 1 stream) + until (= slot-id +end+) + do + (let ((slot (nth slot-id slots))) + (if slot + (setf (standard-instance-access instance + (slot-definition-location slot)) + (read-slot)) + (read-slot))))) + instance)) + +;;; collection + +(defmethod write-object ((collection collection) stream) + (write-n-bytes #.(type-code 'collection) 1 stream)) + +(defreader collection (stream) + (declare (ignore stream)) + *collection*) + +;;; +#+sbcl (declaim (inline %fast-allocate-instance)) + +#+sbcl +(defun %fast-allocate-instance (wrapper initforms) + (declare (simple-vector initforms)) + (let ((instance (sb-pcl::make-instance->constructor-call + (copy-seq initforms) (sb-pcl::safe-code-p)))) + (setf (sb-pcl::std-instance-slots instance) + wrapper) + instance)) + +#+sbcl +(defun fast-allocate-instance (class) + (declare (optimize speed)) + (if (typep class 'storable-class) + (let ((initforms (class-initforms class)) + (wrapper (sb-pcl::class-wrapper class))) + (%fast-allocate-instance wrapper initforms)) + (allocate-instance class))) + +(defun clear-cache (collection) + (setf (classes collection) (make-class-cache) + (packages collection) (make-s-packages))) + +(defun read-file (function file) + (with-io-file (stream file) + (loop until (stream-end-of-file-p stream) + do (let ((object (read-next-object stream))) + (when (and (not (typep object 'class)) + (typep object 'standard-object)) + (funcall function object)))))) + +(defun load-data (collection file function) + (with-collection collection + (read-file function file))) + +(defun save-data (collection &optional file) + (let ((*written-objects* (make-hash-table :test 'eq))) + (clear-cache collection) + (with-collection collection + (with-io-file (stream file + :direction :output) + (dump-data stream))) + (clear-cache collection) + (values))) + +(defun save-doc (collection document &optional file) + (let ((*written-objects* (make-hash-table :test 'eq))) + (with-collection collection + (with-io-file (stream file + :direction :output + :append t) + (write-top-level-object document stream))))) + +;;; DB Functions + +(defmethod sum ((collection collection) &key function element) + (let* ((sum 0) + (function (or function + (lambda (doc) + (incf sum (get-val doc element)))))) + (map-docs nil + function + collection) + sum)) + +(defmethod max-val ((collection collection) &key function element) + (let* ((max 0) + (function (or function + (lambda (doc) + (if (get-val doc element) + (if (> (get-val doc element) max) + (setf max (get-val doc element)))))))) + (map-docs nil + function + collection) + max)) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/document.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/document.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,67 @@ +;;; obj/db/document.lisp --- Database Document Objects + +;; Spliced from XDB, currently not in use outside of it + +;;; Code: +(in-package :xdb) +;;; Document +(defclass document () + ((collection :initarg :collection + :accessor collection) + (key :initarg :key + :accessor key) + (doc-type :initarg :doc-type + :initform nil + :accessor doc-type))) + +(defmethod duplicate-doc-p ((doc document) test-doc) + (or (eq doc test-doc) + (equal (key doc) (key test-doc)))) + +(defmethod add ((doc document) &key collection duplicate-doc-p-func) + (when doc + (if (slot-boundp doc 'collection) + (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p)) + (error "Must specify collection to add document to.")))) + +(defmethod get-val ((doc document) element &optional data-type) + (declare (ignore data-type)) + (if (slot-boundp doc element) + (slot-val doc element))) + +(defmethod (setf get-val) (new-value (doc document) element &optional data-type) + (declare (ignore data-type)) + (if doc + (setf (slot-value doc element) new-value))) + +(defclass document-join (join-docs) + ()) + +(defclass document-join-result (join-result) + ()) + +(defmethod get-val ((composite-doc document-join-result) element &optional data-type) + (declare (ignore data-type)) + (map 'list + (lambda (doc) + (cons (doc-type doc) (get-val doc element))) + (docs composite-doc))) + + +(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal)) + (map-docs + nil + (lambda (doc) + (when (apply test (get-val doc element) value) + (return-from get-doc doc))) + collection)) + + +(defmethod find-doc ((collection document-join) &key test) + (if test + (map-docs + nil + (lambda (doc) + (when (apply test doc) + (return-from find-doc doc))) + collection))) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/io.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/io.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,265 @@ +;;; io/blob.lisp --- Blob Database IO + +;; + +;;; Code: +(in-package :xdb) + +;;; IO +(defvar *fsync-data* nil) + +(defconstant +buffer-size+ 8192) + +(deftype word () 'sb-ext:word) + +(defstruct (input-stream + (:predicate nil)) + (fd nil :type word) + (left 0 :type word) + (buffer-start (sb-sys:sap-int + (sb-alien::%make-alien (* sb-vm:n-byte-bits + (+ +buffer-size+ 3)))) + :type word) + (buffer-end 0 :type word) + (buffer-position 0 :type word)) + +(defstruct (output-stream + (:predicate nil)) + (fd nil :type word) + (buffer-start (sb-sys:sap-int + (sb-alien::%make-alien (* sb-vm:n-byte-bits + (+ +buffer-size+ 3)))) + :type word) + (buffer-end 0 :type word) + (buffer-position 0 :type word)) + +(defun open-file (file-stream + &key direction) + (if (eql direction :output) + (let ((output (make-output-stream + :fd (sb-sys:fd-stream-fd file-stream)))) + (setf (output-stream-buffer-position output) + (output-stream-buffer-start output) + (output-stream-buffer-end output) + (+ (output-stream-buffer-start output) + +buffer-size+)) + output) + (make-input-stream + :fd (sb-sys:fd-stream-fd file-stream) + :left (file-length file-stream)))) + +(defun close-input-stream (stream) + (sb-alien:alien-funcall + (sb-alien:extern-alien "free" + (function (values) sb-alien:long)) + (input-stream-buffer-start stream))) + +(defun close-output-stream (stream) + (flush-buffer stream) + (sb-alien:alien-funcall + (sb-alien:extern-alien "free" + (function (values) sb-alien:long)) + (output-stream-buffer-start stream))) + +(declaim (inline stream-end-of-file-p)) +(defun stream-end-of-file-p (stream) + (and (>= (input-stream-buffer-position stream) + (input-stream-buffer-end stream)) + (zerop (input-stream-left stream)))) + +(declaim (inline sap-ref-24)) +(defun sap-ref-24 (sap offset) + (declare (optimize speed (safety 0)) + (fixnum offset)) + (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset))) + +(declaim (inline n-sap-ref)) +(defun n-sap-ref (n sap &optional (offset 0)) + (funcall (ecase n + (1 #'sb-sys:sap-ref-8) + (2 #'sb-sys:sap-ref-16) + (3 #'sap-ref-24) + (4 #'sb-sys:sap-ref-32)) + sap + offset)) + +(declaim (inline unix-read)) +(defun unix-read (fd buf len) + (declare (optimize (sb-c::float-accuracy 0) + (space 0))) + (declare (type sb-unix::unix-fd fd) + (type word len)) + (sb-alien:alien-funcall + (sb-alien:extern-alien "read" + (function sb-alien:int + sb-alien:int sb-alien:long sb-alien:int)) + fd buf len)) + +(declaim (inline unix-read)) +(defun unix-write (fd buf len) + (declare (optimize (sb-c::float-accuracy 0) + (space 0))) + (declare (type sb-unix::unix-fd fd) + (type word len)) + (sb-alien:alien-funcall + (sb-alien:extern-alien "write" + (function sb-alien:int + sb-alien:int sb-alien:long sb-alien:int)) + fd buf len)) + +(defun fill-buffer (stream offset) + (let ((length (unix-read (input-stream-fd stream) + (+ (input-stream-buffer-start stream) offset) + (- +buffer-size+ offset)))) + (setf (input-stream-buffer-end stream) + (+ (input-stream-buffer-start stream) (+ length offset))) + (decf (input-stream-left stream) length)) + t) + +(defun refill-buffer (n stream) + (declare (type word n) + (input-stream stream)) + (let ((left-n-bytes (- (input-stream-buffer-end stream) + (input-stream-buffer-position stream)))) + (when (> (- n left-n-bytes) + (input-stream-left stream)) + (error "End of file ~a" stream)) + (unless (zerop left-n-bytes) + (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0) + (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream))))) + (fill-buffer stream left-n-bytes)) + (let ((start (input-stream-buffer-start stream))) + (setf (input-stream-buffer-position stream) + (+ start n))) + t) + +(declaim (inline advance-input-stream)) +(defun advance-input-stream (n stream) + (declare (optimize (space 0)) + (type word n) + (type input-stream stream)) + (let* ((sap (input-stream-buffer-position stream)) + (new-sap (sb-ext:truly-the word (+ sap n)))) + (declare (word sap new-sap)) + (cond ((> new-sap (input-stream-buffer-end stream)) + (refill-buffer n stream) + (sb-sys:int-sap (input-stream-buffer-start stream))) + (t + (setf (input-stream-buffer-position stream) + new-sap) + (sb-sys:int-sap sap))))) + +(declaim (inline read-n-bytes)) +(defun read-n-bytes (n stream) + (declare (optimize (space 0)) + (type word n)) + (n-sap-ref n (advance-input-stream n stream))) + +(declaim (inline read-n-signed-bytes)) +(defun read-n-signed-bytes (n stream) + (declare (optimize speed) + (sb-ext:muffle-conditions sb-ext:compiler-note) + (type (integer 1 4) n)) + (funcall (ecase n + (1 #'sb-sys:signed-sap-ref-8) + (2 #'sb-sys:signed-sap-ref-16) + ;; (3 ) + (4 #'sb-sys:signed-sap-ref-32)) + (advance-input-stream n stream) + 0)) + +(declaim (inline write-n-signed-bytes)) +(defun write-n-signed-bytes (value n stream) + (declare (optimize speed) + (sb-ext:muffle-conditions sb-ext:compiler-note) + (fixnum n)) + (ecase n + (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0) + value)) + (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0) + value)) + ;; (3 ) + (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0) + value))) + t) + +(defun flush-buffer (stream) + (unix-write (output-stream-fd stream) + (output-stream-buffer-start stream) + (- (output-stream-buffer-position stream) + (output-stream-buffer-start stream)))) + +(declaim (inline advance-output-stream)) +(defun advance-output-stream (n stream) + (declare (optimize (space 0) (safety 0)) + (type word n) + (type output-stream stream) + ((integer 1 4) n)) + (let* ((sap (output-stream-buffer-position stream)) + (new-sap (sb-ext:truly-the word (+ sap n)))) + (declare (word sap new-sap)) + (cond ((> new-sap (output-stream-buffer-end stream)) + (flush-buffer stream) + (setf (output-stream-buffer-position stream) + (+ (output-stream-buffer-start stream) + n)) + (sb-sys:int-sap (output-stream-buffer-start stream))) + (t + (setf (output-stream-buffer-position stream) + new-sap) + (sb-sys:int-sap sap))))) + +(declaim (inline write-n-bytes)) +(defun write-n-bytes (value n stream) + (declare (optimize (space 0)) + (type word n)) + (setf (sb-sys:sap-ref-32 + (advance-output-stream n stream) + 0) + value)) +;;; + +(declaim (inline copy-mem)) +(defun copy-mem (from to length) + (let ((words-end (- length (rem length sb-vm:n-word-bytes)))) + (loop for i by sb-vm:n-word-bytes below words-end + do (setf (sb-sys:sap-ref-word to i) + (sb-sys:sap-ref-word from i))) + (loop for i from words-end below length + do (setf (sb-sys:sap-ref-8 to i) + (sb-sys:sap-ref-8 from i))))) + +(declaim (inline read-ascii-string-optimized)) +(defun read-ascii-string-optimized (length string stream) + (declare (type fixnum length) + (optimize (speed 3)) + ) + (sb-sys:with-pinned-objects (string) + (let ((sap (advance-input-stream length stream)) + (string-sap (sb-sys:vector-sap string))) + (copy-mem sap string-sap length))) + string) +(defmacro with-io-file ((stream file + &key append (direction :input)) + &body body) + (let ((fd-stream (gensym))) + `(with-open-file (,fd-stream ,file + :element-type '(unsigned-byte 8) + :direction ,direction + ,@(and (eql direction :output) + `(:if-exists ,(if append + :append + :supersede))) + ,@(and append + `(:if-does-not-exist :create))) + (let ((,stream (open-file ,fd-stream :direction ,direction))) + (unwind-protect + (progn ,@body) + ,@(ecase direction + (:output + `((close-output-stream ,stream) + (when *fsync-data* + (sb-posix:fdatasync + (sb-sys:fd-stream-fd ,fd-stream))))) + (:input + `((close-input-stream ,stream))))))))) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/pkg.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/pkg.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,3 @@ +(defpackage :xdb + (:use :cl :std :seq :db :obj/meta/storable :obj/id) + (:export :xdb :dbs :add-collection)) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/proto.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/proto.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,86 @@ +(in-package :xdb) + +(defgeneric initialize-doc-container (collection) + (:documentation + "Create the docs container and set the collection's docs to the container. +If you specialize this then you have to specialize add-doc, store-doc, +sort-collection, sort-collection-temporary and union-collection. ")) + +(defgeneric map-docs (result-type function collection &rest more-collections) + (:documentation + "Applies the function accross all the documents in the collection")) + +(defgeneric duplicate-doc-p (doc test-doc) + (:method ((a t) (b t)))) + +(defgeneric find-duplicate-doc (collection doc &key function) + (:documentation "Load collection from a file.")) + +(defgeneric add-doc (collection doc &key duplicate-doc-p-func) + (:documentation "Add a document to the docs container.")) + +(defgeneric store-doc (collection doc &key duplicate-doc-p-func) + (:documentation "Serialize the doc to file and add it to the collection.")) + +(defgeneric serialize-doc (collection doc &key) + (:documentation "Serialize the doc to file.")) + +(defgeneric serialize-docs (collection &key duplicate-doc-p-func) + (:documentation "Store all the docs in the collection on file and add it to the collection.")) + +(defgeneric load-from-file (collection file) + (:documentation "Load collection from a file.")) + +(defgeneric get-collection (db name) + (:documentation "Returns the collection by name.")) + +(defgeneric add-collection (db name &key load-from-file-p) + (:documentation "Adds a collection to the db.")) + +(defgeneric snapshot (collection) + (:documentation "Write out a snapshot.")) + +(defgeneric load-db (db &key load-from-file-p) + (:documentation "Loads all the collections in a location.")) + +(defgeneric get-docs (db collection-name &key return-type &allow-other-keys) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc (collection value &key element test) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc-complex (test element value collection &rest more-collections) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc-simple (element value collection &rest more-collections) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric find-doc (collection &key test) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric find-doc-complex (test collection &rest more-collections) + (:documentation "Returns the first doc that matches the test.")) + +(defgeneric find-docs (return-type test collection)) + +(defgeneric union-collection (return-type collection &rest more-collections)) + +(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func) + (:documentation "This sorts the collection 'permanantly'.")) + +(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func) + (:documentation "This does not sort the actual collection but returns an array +of sorted docs.")) + +(defgeneric sum (collection &key function &allow-other-keys) + (:documentation "Applies the function to all the docs in the collection and returns the sum of +the return values.")) + +(defgeneric max-val (collection &key function element)) + +;;; Document +(defgeneric add (doc &key collection duplicate-doc-p-func) + (:documentation "Add a document to the docs container.")) + +;;; Disk +(defgeneric write-object (object stream)) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/tests.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/tests.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,231 @@ +(defpackage :xdb/tests + (:use :cl :rt :obj/db :obj/id :xdb :obj/meta/storable)) + +(in-package :xdb/tests) +(defsuite :xdb) +(in-suite :xdb) + +(defparameter *tree* nil) + +(defclass test-doc-non-storable (id) + ((eid :initarg :eid) + (aa :initarg :aa) + (bb :initarg :bb) + (cc :initarg :cc) + (dd :initarg :dd) + (ee :initarg :ee) + (ff :initarg :ff) + (hh :initarg :hh) + (data :initarg :data + :initform (make-hash-table) + :accessor data) + (key :initarg :key + :initform nil + :accessor key) + (type :initarg :type + :initform nil))) + +(defclass test-doc-storable () + ((eid :initarg :eid) + (aa :initarg :aa) + (bb :initarg :bb) + (cc :initarg :cc) + (dd :initarg :dd) + (ee :initarg :ee) + (ff :initarg :ff) + (hh :initarg :hh) + (data :initarg :data + :initform (make-hash-table) + :accessor data) + (key :initarg :key + :initform nil + :accessor key) + (type :initarg :type + :initform nil)) + (:metaclass storable-class)) + +(defun make-doc-test (type key data) + (let ((doc-obj (make-instance 'test-doc-storable :key key :type type))) + (dolist (pair data) + (setf (gethash (first pair) (data doc-obj)) (second pair))) + doc-obj)) + +(defun test-store-doc (collection times) + (dotimes (i times) + (xdb::store-doc collection + (make-doc-test + "Test Doc" + i + (list + (list "id" i) + (list "eid" i) + (list "aa" (format nil "~R" (random 51234))) + (list "bb" (format nil "~R" (random 1234))) + (list "cc" (format nil "~R" (random 1234))) + (list "dd" (format nil "~R" (random 1234))) + (list "ee" (format nil "~R" (random 1234))) + (list "ff" (format nil "~R" (random 1234))) + (list "gg" (format nil "~R" (random 1234))) + (list "hh" (format nil "~R" (random 1234)))))))) + +(defun db-test (n) + (let* ((db (make-instance 'xdb :location "/tmp/db-test/")) + (col (add-collection db "test" :load-from-file-p nil))) + (time (test-store-doc col n)) + ;; (time (snapshot db)) + ;; (time (sum col "eid")) + ;; (time (find-doc col "eid" 50)) + ;; (time (sort-collection col)) + )) + +(defun test-store-docx (collection times) + (dotimes (i times) + + (xdb::store-doc collection + + (make-doc-test + "Test Doc" + i + (list + (list "id" i) + (list "eid" i) + (list "aa" (random 51234)) + (list "bb" (format nil "~R" (random 1234))) + (list "cc" (format nil "~R" (random 1234))) + (list "dd" (format nil "~R" (random 1234))) + (list "ee" (format nil "~R" (random 1234))) + (list "ff" (format nil "~R" (random 1234))) + (list "gg" (format nil "~R" (random 1234))) + (list "hh" (get-universal-time)))) + ) + + (if (equal (mod i 100000) 0) + (sb-ext:gc :full t)))) + +(defun test-store-doc-storable-object (collection times) + (dotimes (i times) + (xdb::store-doc collection + (make-instance 'test-doc-storable :key i :type "Test Doc" + :id i + :eid i + :aa (random 51234) + :bb (format nil "~R" (random 1234)) + :cc (format nil "~R" (random 1234)) + :dd (format nil "~R" (random 1234)) + :ee (format nil "~R" (random 1234)) + :ff (format nil "~R" (random 1234)) + :hh (get-universal-time)) + + ) + + (if (equal (mod i 100000) 0) + (sb-ext:gc :full t)))) + +(defun test-store-doc-non-storable-object (collection times) + (dotimes (i times) + (xdb::store-doc collection + (make-instance 'test-doc-non-storable :key i :type "Test Doc" + :id i + :eid i + :aa (random 51234) + :bb (format nil "~R" (random 1234)) + :cc (format nil "~R" (random 1234)) + :dd (format nil "~R" (random 1234)) + :ee (format nil "~R" (random 1234)) + :ff (format nil "~R" (random 1234)) + :hh (get-universal-time)) + + ) + + (if (equal (mod i 100000) 0) + (sb-ext:gc :full t)))) + +(defun test-store-doc-hash (collection times) + (dotimes (i times) + (let ((hash (make-hash-table :test 'equal))) + (setf (gethash 'key hash) i) + (setf (gethash "id" hash) i) + (setf (gethash "eid" hash) i) + (setf (gethash "bb" hash) (format nil "~R" (random 1234))) + (setf (gethash "cc" hash) (format nil "~R" (random 1234))) + (setf (gethash "dd" hash) (format nil "~R" (random 1234))) + (setf (gethash "ee" hash) (format nil "~R" (random 1234))) + (setf (gethash "ff" hash) (format nil "~R" (random 1234))) + (setf (gethash "stamp" hash) (get-universal-time)) + (xdb::store-doc collection hash)) + + (if (equal (mod i 100000) 0) + (sb-ext:gc :full t)))) + + +(defun test-store-doc-list (collection times) + (dotimes (i times) + (xdb::store-doc collection (list + (list 'key i) + (list "id" i) + (list "eid" i) + (list "aa" (random 51234)) + (list "bb" (format nil "~R" (random 1234))) + (list "cc" (format nil "~R" (random 1234))) + (list "dd" (format nil "~R" (random 1234))) + (list "ee" (format nil "~R" (random 1234))) + (list "ff" (format nil "~R" (random 1234))) + (list "gg" (format nil "~R" (random 1234))) + (list "stamp" (get-universal-time)))) + + (if (equal (mod i 100000) 0) + (sb-ext:gc :full t)))) + +(defparameter db (make-instance 'xdb :location "/tmp/db-test/")) + +(defparameter col-hash (add-collection db "test-hash" :load-from-file-p nil)) + +(defparameter col-list (add-collection db "test-list" :load-from-file-p nil)) +(defparameter col-object (add-collection db "test-object" :load-from-file-p nil)) +(defparameter col-object-storable (add-collection db "test-object-storable" :load-from-file-p nil)) + +;;; DB +(deftest db () + "Test database protocol." + (format t "Hash Test~%") + (format t "Store~%") + (time (test-store-doc-hash col-hash 10000)) + (format t "Sum~%") + (time (xdb::sum col-hash :element "id")) + (format t "Find~%") + (time (xdb::find-doc col-hash :test (lambda (doc) (equal (get-val doc "id") 500)))) + (format t "Sort~%") + (time (xdb::sort-collection col-hash)) + (format t "List Test~%") + (format t "Store~%") + (time (test-store-doc-list col-list 10000)) + (format t "Sum~%") + (time (xdb::sum col-list :element "id")) + (format t "Find~%") + (time (xdb::find-doc col-list :test (lambda (doc) (equal (get-val doc "id") 500)))) + (format t "Sort~%") + (time (xdb::sort-collection col-list)) + + + (format t "Object non storable Test~%") + (format t "Store~%") + (time (test-store-doc-non-storable-object col-object 10000)) + (format t "Sum~%") + (time (xdb::sum col-object :element 'id)) + (format t "Find~%") + (time (xdb::find-doc col-object :test (lambda (doc) (equal (get-val doc 'id) 500)))) + (format t "Sort~%") + (time (xdb::sort-collection col-object)) + + + (setf xdb::*fsync-data* nil) + (format t "Object storable Test~%") + (format t "Store~%") + (time (test-store-doc-storable-object col-object-storable 10000)) + (format t "Sum~%") + (time (xdb::sum col-object-storable :element 'id)) + (format t "Find~%") + (time (xdb::find-doc col-object-storable :test (lambda (doc) (equal (get-val doc 'id) 500)))) + (format t "Sort~%") + (time (xdb::sort-collection col-object-storable))) + diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/xdb.asd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/xdb.asd Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,14 @@ +(defsystem :xdb + :depends-on (:std :obj) + :serial t + :components ((:file "pkg") + (:file "io") + (:file "disk") + (:file "document") + (:file "xdb")) + :in-order-to ((test-op (test-op "xdb/tests")))) + +(defsystem :xdb/tests + :depends-on (:rt :obj :xdb) + :components ((:file "tests")) + :perform (test-op (o c) (symbol-call :rt :do-tests :xdb))) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/db/xdb/xdb.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/db/xdb/xdb.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,292 @@ +(in-package :xdb) + +;;; XDB +(defclass xdb () + ((location :initarg :location + :accessor location + :initform (required-argument "Location is required")) + (collections :initarg :collections + :accessor collections + :initform (make-hash-table :test 'equal)))) + +(defclass dbs () + ((databases :initarg :databases + :accessor databases + :initform (make-hash-table :test 'equal)) + (base-path :initarg :base-path + :initform "/tmp/db/" + :accessor base-path))) + +(defmethod get-db ((dbs dbs) name) + (gethash name (databases dbs))) + +(defun parse-db-path (path) + (make-pathname :directory + (list* :relative + (etypecase path + (cons path + path) + (string path + (list path)))))) + +(defmethod add-db ((dbs dbs) name &key base-path load-from-file-p) + (unless (gethash name (databases dbs)) + (let* ((base-path (or base-path (base-path dbs))) + (db-path (merge-pathnames (parse-db-path name) base-path)) + (db (make-instance 'xdb :location db-path))) + (ensure-directories-exist db-path) + (setf (gethash name (databases dbs)) db) + (if load-from-file-p + (load-db db :load-from-file-p load-from-file-p))))) + +(defparameter *dbs* nil) + +(defun dbs () + *dbs*) + +(defmethod initialize-doc-container ((collection collection)) + (setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0))) + +(defmethod map-docs (result-type function (collection collection) + &rest more-collections) + (let ((result + (map result-type function (docs collection)))) + (loop for collection in more-collections + for results = (map result-type function (docs collection)) + if result-type + do (setf result (concatenate result-type result results))) + result)) + +(defmethod find-duplicate-doc ((collection collection) doc &key function) + (let ((test (or function #'duplicate-doc-p))) + (map-docs + nil + (lambda (docx) + (when (funcall test doc docx) + (return-from find-duplicate-doc docx))) + collection))) + +(defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func) + (when doc + (if duplicate-doc-p-func + (let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func))) + (if (not dup) + (vector-push-extend doc (docs collection)) + (setf dup doc) ;;doing this because + )) + (vector-push-extend doc (docs collection))))) + +(defmethod store-doc ((collection collection) doc + &key (duplicate-doc-p-func #'duplicate-doc-p)) + (let ((dup (and duplicate-doc-p-func + (find-duplicate-doc collection doc + :function duplicate-doc-p-func)))) + ;; a document might be considered duplicate based on the data + ;;contained and not its eql status as lisp object so we have to replace + ;;it in the array with the new object effectively updating the data. + (if dup + (setf dup doc) + (vector-push-extend doc (docs collection))) + (serialize-doc collection doc)) + collection) + +(defmethod serialize-doc ((collection collection) doc &key) + (let ((path (make-pathname :type "log" :defaults (db::path collection)))) + (ensure-directories-exist path) + (db::save-doc collection doc path)) + doc) + +(defmethod serialize-docs (collection &key duplicate-doc-p-func) + (map-docs + nil + (lambda (doc) + (store-doc collection doc + :duplicate-doc-p-func duplicate-doc-p-func)) + collection)) + +(defmethod load-from-file ((collection collection) file) + (when (probe-file file) + (db::load-data collection file + (lambda (object) + (add-doc collection object))))) + +(defmethod get-collection ((db xdb) name) + (gethash name (collections db))) + +(defun make-new-collection (name db &key collection-class) + (let ((collection + (make-instance collection-class + :name name + :path (merge-pathnames name (location db))))) + (initialize-doc-container collection) + collection)) + +(defmethod add-collection ((db xdb) name + &key (collection-class 'collection) load-from-file-p) + (let ((collection (or (gethash name (collections db)) + (setf (gethash name (collections db)) + (make-new-collection name db + :collection-class collection-class))))) + (ensure-directories-exist (db::path collection)) + (when load-from-file-p + (load-from-file collection + (make-pathname :defaults (db::path collection) + :type "snap")) + (load-from-file collection + (make-pathname :defaults (db::path collection) + :type "log"))) + collection)) + +(defun append-date (name) + (format nil "~a-~a" name (file-date))) + +(defmethod snapshot ((collection collection)) + (let* ((backup (merge-pathnames "backup/" (db::path collection))) + (log (make-pathname :type "log" :defaults (db::path collection))) + (snap (make-pathname :type "snap" :defaults (db::path collection))) + (backup-name (append-date (db::name collection))) + (log-backup (make-pathname :name backup-name + :type "log" + :defaults backup)) + (snap-backup (make-pathname :name backup-name + :type "snap" + :defaults backup))) + (ensure-directories-exist backup) + (when (probe-file snap) + (rename-file snap snap-backup)) + (when (probe-file log) + (rename-file log log-backup)) + (db::save-data collection snap))) + +(defmethod snapshot ((db xdb)) + (maphash (lambda (key value) + (declare (ignore key)) + (snapshot value)) + (collections db))) + +(defmethod load-db ((db xdb) &key load-from-file-p) + (let ((unique-collections (make-hash-table :test 'equal))) + (dolist (path (directory (format nil "~A/*.*" (location db)))) + (when (pathname-name path) + (setf (gethash (pathname-name path) unique-collections) + (pathname-name path)))) + (maphash #'(lambda (key value) + (declare (ignore key)) + (add-collection db value :load-from-file-p load-from-file-p)) + unique-collections))) + +(defmethod get-docs ((db xdb) collection-name &key return-type) + (let ((col (gethash collection-name (collections db)))) + (if return-type + (coerce return-type + (docs col)) + (docs col)))) + +(defmethod get-doc (collection value &key (element 'key) (test #'equal)) + (map-docs + nil + (lambda (doc) + (when (funcall test (get-val doc element) value) + (return-from get-doc doc))) + collection)) + +(defmethod get-doc-complex (test element value collection &rest more-collections) + (apply #'map-docs + nil + (lambda (doc) + (when (apply test (list (get-val doc element) value)) + (return-from get-doc-complex doc))) + collection + more-collections)) + +(defmethod find-doc (collection &key test) + (if test + (map-docs + nil + (lambda (doc) + (when (funcall test doc) + (return-from find-doc doc))) + collection))) + +(defmethod find-doc-complex (test collection &rest more-collections) + (apply #'map-docs + (lambda (doc) + (when (funcall test doc) + (return-from find-doc-complex doc))) + collection + (cdr more-collections))) + +(defmethod find-docs (return-type test collection) + (coerce (loop for doc across (docs collection) + when (funcall test doc) + collect doc) + return-type)) + +(defclass union-docs () + ((docs :initarg :docs + :accessor :docs))) + +(defmethod union-collection (return-type (collection collection) &rest more-collections) + (make-instance + 'union-docs + :docs (apply #'map-docs (list return-type collection more-collections)))) + +(defclass join-docs () + ((docs :initarg :docs + :accessor :docs))) + +(defclass join-result () + ((docs :initarg :docs + :accessor :docs))) + +(defun sort-key (doc) + (get-val doc 'key)) + +;; TODO: How to update log if collection is sorted? Make a snapshot? +(defmethod sort-collection ((collection collection) + &key return-sort + (sort-value-func #'sort-key) (sort-test-func #'>)) + (setf (docs collection) + (sort (docs collection) + sort-test-func + :key sort-value-func)) + (if return-sort + (docs collection) + t)) + +(defmethod db::sort-collection-temporary ((collection collection) + &key (sort-value-func #'sort-key) (sort-test-func #'>)) + (let ((sorted-array (copy-array (docs collection)))) + (setf sorted-array + (sort sorted-array + sort-test-func + :key sort-value-func)) + sorted-array)) + +(defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func #'>)) + :documentation "Sorts array/list of docs and returns the sorted array." + (sort docs + sort-test-func + :key sort-value-func)) + +;;Add method for validation when updating a collection. + +(defclass xdb-sequence () + ((key :initarg :key + :accessor key) + (value :initarg :value + :accessor value))) + +(defmethod enable-sequences ((xdb xdb)) + (add-collection xdb "sequences" + :collection-class 'collection + :load-from-file-p t)) + +(defmethod next-sequence ((xdb xdb) key) + (let ((doc (get-doc (get-collection xdb "sequences") key))) + (unless doc + (setf doc (make-instance 'xdb-sequence :key key :value 0))) + (incf (get-val doc 'value)) + (store-doc (get-collection xdb "sequences") + doc) + (get-val doc 'value))) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/examples.asd --- a/examples/examples.asd Sun Apr 14 20:48:05 2024 -0400 +++ b/examples/examples.asd Sun Jun 16 22:15:04 2024 -0400 @@ -9,9 +9,14 @@ ;; (:file "fast") (:file "filtered"))) (:file "vegadat") + (:file "mbdump") (:module "db" :components ((:file "cl-simple-example-raw") (:file "mini-redis") (:file "tao") - (:file "mbdb"))))) + (:file "mbdb"))) + (:module "net" + :components ((:file "yoctochat"))) + (:module "app" + :components ((:file "mpk"))))) diff -r 6b652d7d6663 -r 81b7333f27f8 examples/mbdump.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/mbdump.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,114 @@ +;;; examples/mbdump.lisp --- Prepare a sampling of mbdump JSON data + +;; WIP + +;;; Commentary: + +;; - considering sampling 'releases.json' only. could be a really good +;; benchmark. For now we will sample all files. Soon, we may split +;; releases.json into separate files here which is rather trivial +;; anyway. + +;; - using uiop:read-file-line is NOT the right thing to do. This is +;; too bad because I implemented a specialized stream class and then +;; deleted it before committing. + +;; - there are two possible solutions I can think of: + +;; - single-pass :: for each file, read the first line and calculate +;; the minimal space needed to store a json object in a single +;; line. Instead of incrementing over every character to find the +;; next line, we move the position once by the minimum space, then +;; iterate over characters until we find a newline. We walk the +;; entire file and pick up the random indexes. + +;; - double-pass :: for each file, read each line character by +;; character, counting new lines. At each random index calculate +;; and collect the file position. Do a second pass which sets the +;; file position on each iteration before reading a line. + +;;; Code: +#-prelude (ql:quickload :prelude) +(defpackage :mbdump + (:use :cl :std :log :sb-thread :sb-concurrency :dat/json :cli/clap :obj/time :sb-gray) + (:export :main :*target*)) + +(in-package :mbdump) + +;; Ultimately we dump the samples to this directory. It should be +;; roughly 1/10th the original size. +#| (in-readtable :shell) +du -sh data/mbdump # 242G +du -sh /tmp/mbdump # 24G +|# +(defvar *mbdump-directory* (pathname "/mnt/y/data/packy/data/mbdump-full/")) + +(defun init-mbdump-files (&optional (dir *mbdump-directory*)) + "Count the total number of lines in each file under DIR. Return a +hash-table containing filenames->line counts. + +This is single-threaded so it does take some time on the full mbdump +dataset. If you run this make sure to assign the resulting value to +*MBDUMP-FILES*, otherwise use the pre-compiled value." + (let ((files (find-files dir)) + (table (make-hash-table :test 'equal))) + (mapc (lambda (f) + (setf (gethash (file-namestring f) table) (count-file-lines f))) + files) + table)) + +(defvar *mbdump-files* (let ((pairs '(("area.json" . 119164) + ("artist.json" . 2345810) + ("event.json" . 78896) + ("instrument.json" . 1046) + ("label.json" . 271609) + ("place.json" . 63772) + ("recording.json" . 119575) + ("release-group.json" . 3204634) + ("release.json" . 4111554) + ("series.json" . 23376) + ("work.json" . 2078152))) + (table (make-hash-table :test 'equal))) + (dolist (pair pairs table) + (setf (gethash (car pair) table) (cdr pair))))) + +(defvar *target-directory* (pathname (concatenate 'string "/tmp/mbdump-" (file-date) "/"))) + +(defvar *target* nil) + +(defun random-line-indexes (max &optional (count 1000)) + (declare (fixnum max count)) + (let ((ret)) + (labels ((%gen () (let ((int (random max))) + (when (zerop int) (setf int 1)) + (if (find int ret) + (%gen) + int)))) + (sort + (dotimes (i count ret) + (setf ret (cons (%gen) ret))) + #'<)))) + +(defun prep-json-file (file) + (let* ((in-path (merge-pathnames file *mbdump-directory*)) + (out-path (merge-pathnames file *target-directory*)) + (max (gethash (namestring file) *mbdump-files*)) + (count (floor max 10)) + (lines (random-line-indexes (gethash (namestring file) *mbdump-files*))) + (res (cons out-path count))) + (with-open-files ((out out-path :direction :output :external-format '(:utf-8 :replacement "?")) + (in in-path :direction :input :external-format '(:utf-8 :replacement "?"))) + (loop for i in lines + with line = (uiop:read-file-line in :at i) + do (print (file-position in)) + do (write-line line out))) + (push res *target*))) + +(defmain (:return *target*) + (ensure-directories-exist *target-directory*) + (let ((workers)) + (dolist (file (hash-table-keys *mbdump-files*) workers) + (push (make-thread (lambda () (prep-json-file file)) :name (format nil "~A prep" file)) workers)) + (time (wait-for-threads workers)))) + +;; (prep-json-file "label.json") diff -r 6b652d7d6663 -r 81b7333f27f8 examples/net/yoctochat.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/net/yoctochat.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,60 @@ +;;; examples/net/yoctochat.lisp --- Yoctochat Implementation + +;; The tiniest (lisp) chat server on earth! + +;; based on https://github.com/robn/yoctochat + +;; A 'yoctochat' server will: + +;; - take a single commandline argument, the port to listen on +;; - open a listening port +;; - handle multiple connections and disconnections on that port +;; - receive text on a connection, and forward it on to all ofhter connections +;; - produce simple output about what it's doing +;; - demonstrate a single IO multiplexing technique as simply as possible +;; - be well commented! + +;;; Commentary: + +;; This implementation is based on the yc_uring.c implementation which +;; uses io_uring. To use io_uring from Lisp, we use the high-level IO +;; package, which internally calls foreign functions defined in the +;; URING package. + +;; + +;;; Code: +(defpackage :examples/yoctochat + (:use :cl :std :net :cli/clap :io :log :sb-alien) + (:import-from :uring :load-uring)) + +(in-package :examples/yoctochat) + +;; To start using the IO package we should make sure the liburing +;; shared library is properly loaded. This function takes care of that +;; and arranges for the library to be remembered when entering a saved +;; lisp image such that it will be automatically re-opened. +(load-uring t) + +;; Initialize a simple logger to report on what's happening. +;; (setq *logger* (make-logger nil)) + +;; Define some parameters for the queue depth and maximum number of +;; connections allowed on a single server. +(defparameter *num-conns* 128) + +(defparameter *queue-depth* (* 2 *num-conns*)) + +(defclass yc-server (server) + ((connections :initform nil ::type sequence)) + (:documentation "The Yoctochat Server. ")) + +;; The main loop of our yoctochat server. The 'defmain' macro will +;; produce a function 'main' which can be saved as an executable +;; entry-point. +(defmain () + (init-io *queue-depth*) + (setf *io* nil)) + + + diff -r 6b652d7d6663 -r 81b7333f27f8 examples/org/publish.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/org/publish.lisp Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,8 @@ +;;; examples/org/publish.lisp --- Organ Publish Mockup + +;; + +;;; Code: +(defpackage :publish (:use :cl :std :dat :organ :doc)) +(in-package :publish) +(doc:*source-file-types* diff -r 6b652d7d6663 -r 81b7333f27f8 makefile --- a/makefile Sun Apr 14 20:48:05 2024 -0400 +++ b/makefile Sun Jun 16 22:15:04 2024 -0400 @@ -11,7 +11,7 @@ RS:Cargo.toml rustfmt.toml src/crates/* CL:*/*.asd */*.lisp deps:; -clean:;rm -rf */*.fasl;cargo clean +clean:;rm -rf **/*.fasl;cargo clean fmt:$(RS);cargo fmt build:$(RS) $(CL);cargo build --$(MODE);$(L_D) --eval '(asdf:make "demo")' \ diff -r 6b652d7d6663 -r 81b7333f27f8 readme.org --- a/readme.org Sun Apr 14 20:48:05 2024 -0400 +++ b/readme.org Sun Jun 16 22:15:04 2024 -0400 @@ -1,90 +1,4 @@ #+TITTLE: Demo -Welcome to our first demo system. What you will find here is a modular -client-server software stack which can be extended and customized by -the user at runtime. - -* 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 /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/ (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 -(CLOG), docker-client (archlinux, stumpwm, McCLIM), and native-client -which also compiles to WASM (slint-rs). - -* Guide -** Build -- *install dependencies* - #+begin_src bash - ./tools/deps.sh - #+end_src -- *make executables* \\ - Simply run =make build=. Read the ~makefile~ and change the options - as needed. -- MODE :: Mode (debug, release) -- LISP :: Lisp (sbcl, cmucl, ccl) -- CFG :: Config (default.cfg) -** Run -#+begin_src shell - ./demo -i -#+end_src -** Config -Configs can be specified in JSON, TOML, RON, or of course SEXP. See -=default.cfg= for an example. -** Play -The high-level user interface is presented as a multi-modal GUI -application which adapts to the specific application /instances/ -below. -*** Weather -This backend retrieves weather data using the NWS API. -*** Stocks -The 'Stocks' backend features a stock ticker with real-time analysis -capabilities. -*** Bench -This is a benchmark backend for testing the capabilities of our -demo. It spins up some mock services and allows fine-grained control -of input/throughput. -* tasks -** TODO DSLs -- consider tree-sitter parsing layout, use as a guide for developing a - single syntax which expands to Rust or C. -- with-rs -- with-c -- with-rs/c -- with-cargo -- compile-rs/c -*** TODO rs-macroexpand -- rs-gen-file -- rs-defmacro -- rs-macros -- rs-macroexpand -- rs-macroexpand-1 -*** TODO c-macroexpand -- c-gen-file h/c -- c-defmacro -- c-macros -- c-macroexpand -- c-macroexpand-1 -*** TODO slint-macroexpand -- slint-gen-file -- slint-defmacro -- slint-macros -- slint-macroexpand -- slint-macroexpand-1 -*** TODO html (using who) -** TODO web templates -create a basic static page in CL which will be used to host Slint UIs -and other WASM doo-dads in a browser. -** TODO CLI -using clingon, decide on generic options and write it up -** TODO docs -work on doc generation -- Rust and CL should be accounted for. -** TODO tests -We have none! need to make it more comfy - set up testing in all Rust -crates and for the lisp systems. +Welcome to the Compiler Company Demo. What you will find here is a +modular client-server software stack which can be extended and +customized by the user at runtime. diff -r 6b652d7d6663 -r 81b7333f27f8 skelfile --- a/skelfile Sun Apr 14 20:48:05 2024 -0400 +++ b/skelfile Sun Jun 16 22:15:04 2024 -0400 @@ -0,0 +1,7 @@ +;;; demo/skelfile --- Demo Skeleton +:name demo +:author "Richard Westhaver " +:version "0.1.0" +:description "The CC Demo System" +:rules +() \ No newline at end of file diff -r 6b652d7d6663 -r 81b7333f27f8 system-index.txt --- a/system-index.txt Sun Apr 14 20:48:05 2024 -0400 +++ b/system-index.txt Sun Jun 16 22:15:04 2024 -0400 @@ -1,2 +1,3 @@ demo.asd examples/examples.asd +examples/db/xdb/xdb.asd diff -r 6b652d7d6663 -r 81b7333f27f8 vendor/system-index.txt