1.1--- a/default.sxp Sun Apr 14 20:48:05 2024 -0400
1.2+++ b/default.sxp Sun Jun 16 22:15:04 2024 -0400
1.3@@ -1,1 +1,1 @@
1.4-;; demo user configuration file
1.5\ No newline at end of file
1.6+;; demo application config
2.1--- a/docs/notes.org Sun Apr 14 20:48:05 2024 -0400
2.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
2.3@@ -1,41 +0,0 @@
2.4-* ideas
2.5-** use branches for separate levels of expansion
2.6-- or perhaps some other VC feature.. although I don't want any
2.7- parallel to time, as if expansions occur in sequence. Thus things
2.8- like tags don't feel quite right.
2.9-* research
2.10-for libraries, always prefer [[https://common-lisp-libraries.readthedocs.io/][defacto libs]]
2.11-** [[https://github.com/screenshotbot/screenshotbot-oss][screenshotbot-oss]]
2.12-- monolithic repo, includes third-party dependencies
2.13- - full quicklisp source
2.14- - asdf, etc
2.15-- addresses many of my concerns about running CL in prod
2.16-- the repo is too heavy for my liking though
2.17-- I do like the idea of having many systems though
2.18-** DB
2.19-*** CLIENT
2.20-**** [[https://github.com/fukamachi/mito][mito]]
2.21-ORM, sqlite, postgres, mysql support
2.22-**** [[https://github.com/fukamachi/cl-dbi][cl-dbi]]
2.23-database independent interface
2.24-**** [[https://github.com/fukamachi/sxql][sxql]]
2.25-SQL generator
2.26-*** SERVICE
2.27-**** [[https://github.com/launchbadge/sqlx][sqlx]]
2.28-- supports rustls, tokio
2.29-- we should write the service queries using a common-lisp DSL!
2.30- #+begin_src toml
2.31- sqlx = { version = "0.7", features = [ "runtime-tokio", "tls-rustls", "any", "chrono" ] }
2.32- #+end_src
2.33-** LOGGING
2.34-*** CLIENT
2.35-**** [[https://github.com/sharplispers/log4cl/][log4cl]]
2.36-supports slime well
2.37-*** SERVICE
2.38-**** [[https://crates.io/crates/tracing][tracing]]
2.39-**** [[https://crates.io/crates/tokio-console][tokio-console]] - monitoring tool
2.40-works with tracing using the [[https://crates.io/crates/console-subscriber][console-subscriber]] crate
2.41-** UI
2.42-[[https://mcclim.common-lisp.dev/][mcclim]]
2.43-[[https://slint-ui.com/][slint-ui]]
2.44-[[https://github.com/rabbibotton/clog][clog]]
3.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2+++ b/examples/app/mpk.lisp Sun Jun 16 22:15:04 2024 -0400
3.3@@ -0,0 +1,23 @@
3.4+;;; examples/app/mpk.lisp --- MPK demo
3.5+
3.6+;;
3.7+
3.8+;;; Code:
3.9+(in-package :user)
3.10+(defpkg mpk (:use :cl :std :dat :net :obj :log :rdb :packy))
3.11+(in-package :mpk)
3.12+
3.13+(defvar *mpc*)
3.14+
3.15+(defun mpc-init ()
3.16+ (let* ((conn (mpd:connect))
3.17+ (status (mpd:status conn)))
3.18+ (setq mpk::*mpc* conn)
3.19+ (format t "mpd state: ~A~%" (mpd:state conn))
3.20+ (values conn status)))
3.21+
3.22+(defun play () (mpd:play *mpc*))
3.23+(defun stop () (mpd:stop *mpc*))
3.24+(defun pause () (mpd:pause *mpc*))
3.25+
3.26+#+nil (mpc-init)
4.1--- a/examples/db/mbdb.lisp Sun Apr 14 20:48:05 2024 -0400
4.2+++ b/examples/db/mbdb.lisp Sun Jun 16 22:15:04 2024 -0400
4.3@@ -1,15 +1,29 @@
4.4 ;;; examples/mbdb.lisp --- MusicBrainz Database import and analysis
4.5
4.6-;; This example show how to migrate a set of complex JSON objects to
4.7-;; RocksDB using a dump from the MusicBrainz database
4.8+;; This example show how to migrate a set of complex JSON objects and
4.9+;; SQL dumps to RocksDB using data from the MusicBrainz database
4.10 ;; (https://musicbrainz.org/). The files are hosted at
4.11-;; https://packy.compiler.company/data/mbdump
4.12+;; https://packy.compiler.company/data
4.13+
4.14+;;; Commentary:
4.15+
4.16+;; The original data is located here:
4.17+;; https://data.metabrainz.org/pub/musicbrainz/data/
4.18
4.19-;; we parse some of the database schema from the sql files here:
4.20+;; The actual json dumps are quite large (releas.json is 208Gb!), so
4.21+;; we provide our own trimmed down sampling. Each file is sampled
4.22+;; randomly and individually, so actual linkage data is totally
4.23+;; clobbered. If you want to work do some OLAP stuff you will need the
4.24+;; full data set which is packaged as mbdump-full.tar.zst.
4.25+
4.26+;; the data prep script is located at ../mbdump-prep.lisp
4.27+
4.28+;; we parsed some of the database schema from the sql files here:
4.29 ;; https://github.com/metabrainz/musicbrainz-server/tree/master/admin/sql
4.30
4.31 ;;; Code:
4.32-(defpackage :examples/mbdb
4.33+(in-package :std-user)
4.34+(defpkg :examples/mbdb
4.35 (:use :cl :std :dat/json :net/fetch :obj/id :rdb :cli/clap :obj/uuid
4.36 :sb-concurrency :log :dat/csv :dat/proto :sb-thread)
4.37 (:import-from :obj/uuid :make-uuid-from-string)
4.38@@ -51,7 +65,7 @@
4.39 "The oracle assigned to the mbdb system, which should usually be the current thread.")
4.40
4.41 (declaim (task-pool *mbdb-tasks*))
4.42-(defvar *mbdb-tasks* (make-task-pool :oracle *mbdb-oracle*)
4.43+(defvar *mbdb-tasks* (make-task-pool :oracle-id (oracle-id *mbdb-oracle*))
4.44 "The mbdb task pool. This object holds a queue of jobs which are
4.45 dispatched to workers. Results are collected and processed by the
4.46 oracle.")
4.47@@ -66,11 +80,12 @@
4.48 (defvar *mbdump-pack-url* "https://packy.compiler.company/data/mbdump.tar.zst"
4.49 "Remote locaton of MusicBrainz JSON dump pack.")
4.50
4.51+(defvar *mbdb-worker-dir* (merge-pathnames ".import/" *mbdb-path*))
4.52+
4.53 (defvar *mbdump-pack* (merge-pathnames "mbdump.tar.zst" *mbdb-worker-dir*))
4.54+
4.55 (defvar *mbsamp-pack* (merge-pathnames "mbsamp.tar.zst" *mbdb-worker-dir*))
4.56
4.57-(defvar *mbdb-worker-dir* (merge-pathnames ".import/" *mbdb-path*))
4.58-
4.59 (defvar *mbdump-files* nil) ;; set by MBDB-UNPACK
4.60
4.61 (defvar *mbsamp-files* nil) ;; set by MBDB-UNPACK
4.62@@ -112,6 +127,8 @@
4.63 #+nil (extract-mbsamp (car (mbsamp-fetch)))
4.64
4.65 ;;; Parsing
4.66+
4.67+;;;; MBSamp
4.68 (define-constant +mbsamp-null+ "\\N" :test #'string=)
4.69
4.70 (defun nullable (str)
4.71@@ -208,14 +225,6 @@
4.72 (when file
4.73 (dat/csv:read-csv-file file :header nil :delimiter #\Tab :map-fns map-fns))))
4.74
4.75-(defun extract-mbdump-file (file)
4.76- "Extract the contents of a json-dump FILE. Return a json-object."
4.77- (with-open-file (f file)
4.78- ;; (sb-impl::with-array-data
4.79- (loop for x = (json-read f nil)
4.80- while x
4.81- collect x)))
4.82-
4.83 (defmacro with-mbsamp-proc (table shape &body vals)
4.84 (with-gensyms (row i)
4.85 `(coerce
4.86@@ -258,6 +267,15 @@
4.87 (def-mbsamp-proc release 0 1 2 13)
4.88 (def-mbsamp-proc instrument 0 1 2 5 7)
4.89
4.90+;;;; MBDump
4.91+(defun extract-mbdump-file (file)
4.92+ "Extract the contents of a json-dump FILE. Return a json-object."
4.93+ (with-open-file (f file)
4.94+ ;; (sb-impl::with-array-data
4.95+ (loop for x = (json-read f nil)
4.96+ while x
4.97+ collect x)))
4.98+
4.99 (defun extract-mbdump-columns (obj)
4.100 "Extract fields from a json-object, returning a vector of
4.101 uninitialized column-families which can be created with #'create-cfs.
4.102@@ -274,6 +292,8 @@
4.103
4.104 (defclass mbdb-task (task) ())
4.105
4.106+(defclass mbdb-stage (stage) ())
4.107+
4.108 ;;; Main
4.109 (defmain ()
4.110 (let ((*default-pathname-defaults* *mbdb-path*)
4.111@@ -281,17 +301,27 @@
4.112 (*csv-separator* #\Tab)
4.113 (*cpus* (num-cpus))
4.114 (*log-timestamp* nil)
4.115- (*log-level* :warn))
4.116+ (*log-level* :info))
4.117 (log:info! "Welcome to MBDB")
4.118 (ensure-directories-exist *mbdb-worker-dir* :verbose t)
4.119 ;; prepare workers
4.120- (setf *mbdb-oracle* (make-oracle sb-thread:*current-thread*)
4.121- *mbdb-tasks* (make-task-pool :oracle *mbdb-oracle*))
4.122- (push-worker (sb-thread:make-thread #'mbsamp-fetch) *mbdb-tasks*)
4.123+ (setq *mbdb-oracle* (make-oracle sb-thread:*current-thread*))
4.124+ (setq *mbdb-tasks* (make-task-pool :oracle-id (oracle-id *mbdb-oracle*)))
4.125+ ;; (make-workers
4.126+ ;; (push-worker (make-thread #'?) *mbdb-tasks*)
4.127+
4.128 ;; (with-tasks ())
4.129- (let ((job (make-job)))
4.130- (push-task (make-instance 'mbdb-task :object #'mbsamp-fetch) job))
4.131
4.132+ ;; fetch
4.133+ (let ((job (make-job (make-array 2 :fill-pointer 0 :initial-element (make-task) :element-type 'task))))
4.134+ (push-task (make-task #'mbsamp-fetch) job)
4.135+ (push-task (make-task #'mbdump-fetch) job)
4.136+ (push-job job *mbdb-tasks*))
4.137+ ;; unpack
4.138+ (let ((job (make-job (make-array 2 :fill-pointer 0 :initial-element (make-task) :element-type 'task))))
4.139+ (push-task (make-task #'mbsamp-unpack) job)
4.140+ (push-task (make-task #'mbdump-unpack) job)
4.141+ (push-job job *mbdb-tasks*))
4.142 ;; (sb-thread:make-thread #'mbsamp-fetch)
4.143
4.144 ;; prepare column family data
4.145@@ -300,16 +330,16 @@
4.146 (with-db (db *mbdb*)
4.147 (open-db db)
4.148 (setf (rdb-cfs db) *mbsamp-cfs*)
4.149- ;; (create-cfs db)
4.150- (log:info! "database initialized")
4.151- ;;
4.152- (close-db db))
4.153-
4.154+ (backfill-opts db)
4.155+ (log:info! "database initialized"))
4.156 ;; launch tasks
4.157
4.158 ;; wait
4.159- (wait-for-threads (task-pool-workers *mbdb-tasks*))
4.160- ;; summarize
4.161- (info! "mbdb stats" (print-stats *mbdb*))
4.162- ;; close
4.163- ))
4.164+ (unwind-protect
4.165+ (progn
4.166+ (wait-for-threads (task-pool-workers *mbdb-tasks*))
4.167+ ;; summarize
4.168+ (when-let ((stats (print-stats *mbdb*))) (info! "mbdb stats" stats)))
4.169+ ;; close
4.170+ (close-db *mbdb*))))
4.171+
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/examples/db/xdb/disk.lisp Sun Jun 16 22:15:04 2024 -0400
5.3@@ -0,0 +1,838 @@
5.4+(in-package :xdb)
5.5+;;; Disk
5.6+(defclass collection ()
5.7+ ((name :initarg :name
5.8+ :accessor name)
5.9+ (path :initarg :path
5.10+ :accessor path)
5.11+ (docs :initarg :docs
5.12+ :accessor docs)
5.13+ (packages :initform (make-s-packages)
5.14+ :accessor packages)
5.15+ (classes :initform (make-class-cache)
5.16+ :accessor classes)
5.17+ (last-id :initform 0
5.18+ :accessor last-id)
5.19+ (object-cache :initarg :object-cache
5.20+ :initform (make-hash-table :size 1000
5.21+ :test 'eq)
5.22+ :accessor object-cache)
5.23+ (id-cache :initarg :id-cache
5.24+ :initform (make-hash-table :size 1000)
5.25+ :accessor id-cache)))
5.26+
5.27+(eval-when (:compile-toplevel :load-toplevel :execute)
5.28+ (defparameter *codes*
5.29+ #(ascii-string
5.30+ id
5.31+ cons
5.32+ string
5.33+ null
5.34+ storable-class
5.35+ storable-object
5.36+ standard-class
5.37+ standard-object
5.38+ standard-link
5.39+ fixnum
5.40+ bignum
5.41+ ratio
5.42+ double-float
5.43+ single-float
5.44+ complex
5.45+ symbol
5.46+ intern-package-and-symbol
5.47+ intern-symbol
5.48+ character
5.49+ simple-vector
5.50+ array
5.51+ hash-table
5.52+ pathname
5.53+ collection)))
5.54+
5.55+(defvar *statistics* ())
5.56+(defun collect-stats (code)
5.57+ (let* ((type (aref *codes* code))
5.58+ (cons (assoc type *statistics*)))
5.59+ (if cons
5.60+ (incf (cdr cons))
5.61+ (push (cons type 1) *statistics*))
5.62+ type))
5.63+
5.64+(defvar *collection* nil)
5.65+
5.66+(defvar *classes*)
5.67+(defvar *packages*)
5.68+(declaim (vector *classes* *packages*))
5.69+
5.70+(defvar *indexes*)
5.71+(declaim (hash-table *indexes*))
5.72+
5.73+(defvar *written-objects*)
5.74+(declaim (hash-table *indexes*))
5.75+
5.76+(eval-when (:compile-toplevel :load-toplevel :execute)
5.77+ (defun type-code (type)
5.78+ (position type *codes*)))
5.79+
5.80+(defparameter *readers* (make-array (length *codes*)))
5.81+(declaim (type (simple-array function (*)) *readers*))
5.82+
5.83+(defmacro defreader (type (stream) &body body)
5.84+ (let ((name (intern (format nil "~a-~a" type '#:reader))))
5.85+ `(progn
5.86+ (defun ,name (,stream)
5.87+ ,@body)
5.88+ (setf (aref *readers* ,(type-code type))
5.89+ #',name))))
5.90+
5.91+(declaim (inline call-reader))
5.92+(defun call-reader (code stream)
5.93+ ;; (collect-stats code)
5.94+ (funcall (aref *readers* code) stream))
5.95+
5.96+(defconstant +sequence-length+ 2)
5.97+(eval-when (:compile-toplevel :load-toplevel :execute)
5.98+ (defconstant +fixnum-length+ 4))
5.99+(defconstant +char-length+ 2)
5.100+(defconstant +id-length+ 4)
5.101+(defconstant +class-id-length+ 2)
5.102+(defconstant +hash-table-length+ 3)
5.103+
5.104+(defconstant +unbound-slot+ 254)
5.105+(defconstant +end+ 255)
5.106+
5.107+(defconstant +ascii-char-limit+ (code-char 128))
5.108+
5.109+(deftype ascii-string ()
5.110+ '(or
5.111+ #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
5.112+ (satisfies ascii-string-p)))
5.113+
5.114+(defun ascii-string-p (string)
5.115+ (declare (simple-string string))
5.116+ (loop for char across string
5.117+ always (char< char +ascii-char-limit+)))
5.118+
5.119+(deftype storage-fixnum ()
5.120+ `(signed-byte ,(* +fixnum-length+ 8)))
5.121+
5.122+(defun make-class-cache ()
5.123+ (make-array 10 :adjustable t :fill-pointer 0))
5.124+
5.125+(defmacro with-collection (collection &body body)
5.126+ (let ((collection-sym (gensym)))
5.127+ `(let* ((,collection-sym ,collection)
5.128+ (*collection* ,collection-sym)
5.129+ (*packages* (packages ,collection-sym))
5.130+ (*classes* (classes ,collection-sym))
5.131+ (*indexes* (id-cache ,collection-sym)))
5.132+ ,@body)))
5.133+
5.134+;;;
5.135+(defun slot-effective-definition (class slot-name)
5.136+ (find slot-name (class-slots class) :key #'slot-definition-name))
5.137+
5.138+(defun dump-data (stream)
5.139+ (map-docs
5.140+ nil
5.141+ (lambda (document)
5.142+ (write-top-level-object document stream))
5.143+ *collection*))
5.144+
5.145+(defun write-top-level-object (object stream)
5.146+ (if (typep object 'id)
5.147+ (write-storable-object object stream)
5.148+ (write-object object stream)))
5.149+
5.150+(declaim (inline read-next-object))
5.151+(defun read-next-object (stream)
5.152+ (call-reader (read-n-bytes 1 stream) stream))
5.153+
5.154+;;; NIL
5.155+
5.156+(defmethod write-object ((object null) stream)
5.157+ (write-n-bytes #.(type-code 'null) 1 stream))
5.158+
5.159+(defreader null (stream)
5.160+ (declare (ignore stream))
5.161+ nil)
5.162+
5.163+;;; Symbol
5.164+
5.165+(defun make-s-packages ()
5.166+ (make-array 10 :adjustable t :fill-pointer 0))
5.167+
5.168+(defun make-s-package (package)
5.169+ (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
5.170+ (values (vector-push-extend (cons package symbols) *packages*)
5.171+ symbols
5.172+ t)))
5.173+
5.174+(defun find-s-package (package)
5.175+ (loop for i below (length *packages*)
5.176+ for (stored-package . symbols) = (aref *packages* i)
5.177+ when (eq package stored-package)
5.178+ return (values i symbols)
5.179+ finally (return (make-s-package package))))
5.180+
5.181+(defun s-intern (symbol)
5.182+ (multiple-value-bind (package-id symbols new-package)
5.183+ (find-s-package (symbol-package symbol))
5.184+ (let* ((existing (and (not new-package)
5.185+ (position symbol symbols)))
5.186+ (symbol-id (or existing
5.187+ (vector-push-extend symbol symbols))))
5.188+ (values package-id symbol-id new-package (not existing)))))
5.189+
5.190+(defun s-intern-existing (symbol symbols)
5.191+ (vector-push-extend symbol symbols))
5.192+
5.193+(defmethod write-object ((symbol symbol) stream)
5.194+ (multiple-value-bind (package-id symbol-id
5.195+ new-package new-symbol)
5.196+ (s-intern symbol)
5.197+ (cond ((and new-package new-symbol)
5.198+ (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
5.199+ (write-object (package-name (symbol-package symbol)) stream)
5.200+ (write-object (symbol-name symbol) stream))
5.201+ (new-symbol
5.202+ (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
5.203+ (write-n-bytes package-id +sequence-length+ stream)
5.204+ (write-object (symbol-name symbol) stream))
5.205+ (t
5.206+ (write-n-bytes #.(type-code 'symbol) 1 stream)
5.207+ (write-n-bytes package-id +sequence-length+ stream)
5.208+ (write-n-bytes symbol-id +sequence-length+ stream)))))
5.209+
5.210+(defreader symbol (stream)
5.211+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
5.212+ (symbol-id (read-n-bytes +sequence-length+ stream))
5.213+ (package (or (aref *packages* package-id)
5.214+ (error "Package with id ~a not found" package-id)))
5.215+ (symbol (aref (cdr package) symbol-id)))
5.216+ (or symbol
5.217+ (error "Symbol with id ~a in package ~a not found"
5.218+ symbol-id (car package)))))
5.219+
5.220+(defreader intern-package-and-symbol (stream)
5.221+ (let* ((package-name (read-next-object stream))
5.222+ (symbol-name (read-next-object stream))
5.223+ (package (or (find-package package-name)
5.224+ (error "Package ~a not found" package-name)))
5.225+ (symbol (intern symbol-name package))
5.226+ (s-package (nth-value 1 (make-s-package package))))
5.227+ (s-intern-existing symbol s-package)
5.228+ symbol))
5.229+
5.230+(defreader intern-symbol (stream)
5.231+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
5.232+ (symbol-name (read-next-object stream))
5.233+ (package (or (aref *packages* package-id)
5.234+ (error "Package with id ~a for symbol ~a not found"
5.235+ package-id symbol-name)))
5.236+ (symbol (intern symbol-name (car package))))
5.237+ (s-intern-existing symbol (cdr package))
5.238+ symbol))
5.239+
5.240+;;; Integer
5.241+
5.242+(declaim (inline sign))
5.243+(defun sign (n)
5.244+ (if (minusp n)
5.245+ 1
5.246+ 0))
5.247+
5.248+(defun write-fixnum (n stream)
5.249+ (declare (storage-fixnum n))
5.250+ (write-n-bytes #.(type-code 'fixnum) 1 stream)
5.251+ (write-n-signed-bytes n +fixnum-length+ stream))
5.252+
5.253+(defun write-bignum (n stream)
5.254+ (declare ((and integer (not storage-fixnum)) n))
5.255+ (write-n-bytes #.(type-code 'bignum) 1 stream)
5.256+ (write-n-bytes (sign n) 1 stream)
5.257+ (let* ((fixnum-bits (* +fixnum-length+ 8))
5.258+ (n (abs n))
5.259+ (size (ceiling (integer-length n) fixnum-bits)))
5.260+ (write-n-bytes size 1 stream)
5.261+ (loop for position by fixnum-bits below (* size fixnum-bits)
5.262+ do
5.263+ (write-n-bytes (ldb (byte fixnum-bits position) n)
5.264+ +fixnum-length+ stream))))
5.265+
5.266+(defmethod write-object ((object integer) stream)
5.267+ (typecase object
5.268+ (storage-fixnum
5.269+ (write-fixnum object stream))
5.270+ (t (write-bignum object stream))))
5.271+
5.272+(declaim (inline read-sign))
5.273+(defun read-sign (stream)
5.274+ (if (plusp (read-n-bytes 1 stream))
5.275+ -1
5.276+ 1))
5.277+
5.278+(defreader bignum (stream)
5.279+ (let ((fixnum-bits (* +fixnum-length+ 8))
5.280+ (sign (read-sign stream))
5.281+ (size (read-n-bytes 1 stream))
5.282+ (integer 0))
5.283+ (loop for position by fixnum-bits below (* size fixnum-bits)
5.284+ do
5.285+ (setf (ldb (byte fixnum-bits position) integer)
5.286+ (read-n-bytes +fixnum-length+ stream)))
5.287+ (* sign integer)))
5.288+
5.289+(defreader fixnum (stream)
5.290+ (read-n-signed-bytes +fixnum-length+ stream))
5.291+
5.292+;;; Ratio
5.293+
5.294+(defmethod write-object ((object ratio) stream)
5.295+ (write-n-bytes #.(type-code 'ratio) 1 stream)
5.296+ (write-object (numerator object) stream)
5.297+ (write-object (denominator object) stream))
5.298+
5.299+(defreader ratio (stream)
5.300+ (/ (read-next-object stream)
5.301+ (read-next-object stream)))
5.302+
5.303+;;; Float
5.304+
5.305+(defun write-8-bytes (n stream)
5.306+ (write-n-bytes (ldb (byte 32 0) n) 4 stream)
5.307+ (write-n-bytes (ldb (byte 64 32) n) 4 stream))
5.308+
5.309+(defun read-8-bytes (stream)
5.310+ (logior (read-n-bytes 4 stream)
5.311+ (ash (read-n-bytes 4 stream) 32)))
5.312+
5.313+(defmethod write-object ((float float) stream)
5.314+ (etypecase float
5.315+ (single-float
5.316+ (write-n-bytes #.(type-code 'single-float) 1 stream)
5.317+ (write-n-bytes (encode-float32 float) 4 stream))
5.318+ (double-float
5.319+ (write-n-bytes #.(type-code 'double-float) 1 stream)
5.320+ (write-8-bytes (encode-float64 float) stream))))
5.321+
5.322+(defreader single-float (stream)
5.323+ (decode-float32 (read-n-bytes 4 stream)))
5.324+
5.325+(defreader double-float (stream)
5.326+ (decode-float64 (read-8-bytes stream)))
5.327+
5.328+;;; Complex
5.329+
5.330+(defmethod write-object ((complex complex) stream)
5.331+ (write-n-bytes #.(type-code 'complex) 1 stream)
5.332+ (write-object (realpart complex) stream)
5.333+ (write-object (imagpart complex) stream))
5.334+
5.335+(defreader complex (stream)
5.336+ (complex (read-next-object stream)
5.337+ (read-next-object stream)))
5.338+
5.339+;;; Characters
5.340+
5.341+(defmethod write-object ((character character) stream)
5.342+ (write-n-bytes #.(type-code 'character) 1 stream)
5.343+ (write-n-bytes (char-code character) +char-length+ stream))
5.344+
5.345+(defreader character (stream)
5.346+ (code-char (read-n-bytes +char-length+ stream)))
5.347+
5.348+;;; Strings
5.349+
5.350+(defun write-ascii-string (string stream)
5.351+ (declare (simple-string string))
5.352+ (loop for char across string
5.353+ do (write-n-bytes (char-code char) 1 stream)))
5.354+
5.355+(defun write-multibyte-string (string stream)
5.356+ (declare (simple-string string))
5.357+ (loop for char across string
5.358+ do (write-n-bytes (char-code char) +char-length+ stream)))
5.359+
5.360+(defmethod write-object ((string string) stream)
5.361+ (etypecase string
5.362+ ((not simple-string)
5.363+ (call-next-method))
5.364+ #+sb-unicode
5.365+ (simple-base-string
5.366+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
5.367+ (write-n-bytes (length string) +sequence-length+ stream)
5.368+ (write-ascii-string string stream))
5.369+ (ascii-string
5.370+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
5.371+ (write-n-bytes (length string) +sequence-length+ stream)
5.372+ (write-ascii-string string stream))
5.373+ (string
5.374+ (write-n-bytes #.(type-code 'string) 1 stream)
5.375+ (write-n-bytes (length string) +sequence-length+ stream)
5.376+ (write-multibyte-string string stream))))
5.377+
5.378+(declaim (inline read-ascii-string))
5.379+(defun read-ascii-string (length stream)
5.380+ (let ((string (make-string length :element-type 'base-char)))
5.381+ ;#-sbcl
5.382+ (loop for i below length
5.383+ do (setf (schar string i)
5.384+ (code-char (read-n-bytes 1 stream))))
5.385+ #+(and nil sbcl (or x86 x86-64))
5.386+ (read-ascii-string-optimized length string stream)
5.387+ string))
5.388+
5.389+(defreader ascii-string (stream)
5.390+ (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
5.391+
5.392+(defreader string (stream)
5.393+ (let* ((length (read-n-bytes +sequence-length+ stream))
5.394+ (string (make-string length :element-type 'character)))
5.395+ (loop for i below length
5.396+ do (setf (schar string i)
5.397+ (code-char (read-n-bytes +char-length+ stream))))
5.398+ string))
5.399+
5.400+;;; Pathname
5.401+
5.402+(defmethod write-object ((pathname pathname) stream)
5.403+ (write-n-bytes #.(type-code 'pathname) 1 stream)
5.404+ (write-object (pathname-name pathname) stream)
5.405+ (write-object (pathname-directory pathname) stream)
5.406+ (write-object (pathname-device pathname) stream)
5.407+ (write-object (pathname-type pathname) stream)
5.408+ (write-object (pathname-version pathname) stream))
5.409+
5.410+(defreader pathname (stream)
5.411+ (make-pathname
5.412+ :name (read-next-object stream)
5.413+ :directory (read-next-object stream)
5.414+ :device (read-next-object stream)
5.415+ :type (read-next-object stream)
5.416+ :version (read-next-object stream)))
5.417+
5.418+;;; Cons
5.419+
5.420+(defmethod write-object ((list cons) stream)
5.421+ (cond ((circular-list-p list)
5.422+ (error "Can't store circular lists"))
5.423+ (t
5.424+ (write-n-bytes #.(type-code 'cons) 1 stream)
5.425+ (loop for cdr = list then (cdr cdr)
5.426+ do
5.427+ (cond ((consp cdr)
5.428+ (write-object (car cdr) stream))
5.429+ (t
5.430+ (write-n-bytes +end+ 1 stream)
5.431+ (write-object cdr stream)
5.432+ (return)))))))
5.433+
5.434+(defreader cons (stream)
5.435+ (let ((first-cons (list (read-next-object stream))))
5.436+ (loop for previous-cons = first-cons then new-cons
5.437+ for car = (let ((id (read-n-bytes 1 stream)))
5.438+ (cond ((eq id +end+)
5.439+ (setf (cdr previous-cons) (read-next-object stream))
5.440+ (return))
5.441+ ((call-reader id stream))))
5.442+ for new-cons = (list car)
5.443+ do (setf (cdr previous-cons) new-cons))
5.444+ first-cons))
5.445+
5.446+;;; Simple-vector
5.447+
5.448+(defmethod write-object ((vector vector) stream)
5.449+ (typecase vector
5.450+ (simple-vector
5.451+ (write-simple-vector vector stream))
5.452+ (t
5.453+ (call-next-method))))
5.454+
5.455+(defun write-simple-vector (vector stream)
5.456+ (declare (simple-vector vector))
5.457+ (write-n-bytes #.(type-code 'simple-vector) 1 stream)
5.458+ (write-n-bytes (length vector) +sequence-length+ stream)
5.459+ (loop for elt across vector
5.460+ do (write-object elt stream)))
5.461+
5.462+(defreader simple-vector (stream)
5.463+ (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
5.464+ (loop for i below (length vector)
5.465+ do (setf (svref vector i) (read-next-object stream)))
5.466+ vector))
5.467+
5.468+;;; Array
5.469+
5.470+(defun boolify (x)
5.471+ (if x
5.472+ 1
5.473+ 0))
5.474+
5.475+(defmethod write-object ((array array) stream)
5.476+ (write-n-bytes #.(type-code 'array) 1 stream)
5.477+ (write-object (array-dimensions array) stream)
5.478+ (cond ((array-has-fill-pointer-p array)
5.479+ (write-n-bytes 1 1 stream)
5.480+ (write-n-bytes (fill-pointer array) +sequence-length+ stream))
5.481+ (t
5.482+ (write-n-bytes 0 2 stream)))
5.483+ (write-object (array-element-type array) stream)
5.484+ (write-n-bytes (boolify (adjustable-array-p array)) 1 stream)
5.485+ (loop for i below (array-total-size array)
5.486+ do (write-object (row-major-aref array i) stream)))
5.487+
5.488+(defun read-array-fill-pointer (stream)
5.489+ (if (plusp (read-n-bytes 1 stream))
5.490+ (read-n-bytes +sequence-length+ stream)
5.491+ (not (read-n-bytes 1 stream))))
5.492+
5.493+(defreader array (stream)
5.494+ (let ((array (make-array (read-next-object stream)
5.495+ :fill-pointer (read-array-fill-pointer stream)
5.496+ :element-type (read-next-object stream)
5.497+ :adjustable (plusp (read-n-bytes 1 stream)))))
5.498+ (loop for i below (array-total-size array)
5.499+ do (setf (row-major-aref array i) (read-next-object stream)))
5.500+ array))
5.501+
5.502+;;; Hash-table
5.503+
5.504+(defvar *hash-table-tests* #(eql equal equalp eq))
5.505+(declaim (simple-vector *hash-table-tests*))
5.506+
5.507+(defun check-hash-table-test (hash-table)
5.508+ (let* ((test (hash-table-test hash-table))
5.509+ (test-id (position test *hash-table-tests*)))
5.510+ (unless test-id
5.511+ (error "Only standard hashtable tests are supported, ~a has ~a"
5.512+ hash-table test))
5.513+ test-id))
5.514+
5.515+(defmethod write-object ((hash-table hash-table) stream)
5.516+ (write-n-bytes #.(type-code 'hash-table) 1 stream)
5.517+ (write-n-bytes (check-hash-table-test hash-table) 1 stream)
5.518+ (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
5.519+ (loop for key being the hash-keys of hash-table
5.520+ using (hash-value value)
5.521+ do
5.522+ (write-object key stream)
5.523+ (write-object value stream))
5.524+ (write-n-bytes +end+ 1 stream))
5.525+
5.526+(defreader hash-table (stream)
5.527+ (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
5.528+ (size (read-n-bytes +hash-table-length+ stream))
5.529+ (table (make-hash-table :test test :size size)))
5.530+ (loop for id = (read-n-bytes 1 stream)
5.531+ until (eq id +end+)
5.532+ do (setf (gethash (call-reader id stream) table)
5.533+ (read-next-object stream)))
5.534+ table))
5.535+
5.536+;;; storable-class
5.537+
5.538+(defun cache-class (class id)
5.539+ (when (< (length *classes*) id)
5.540+ (adjust-array *classes* (1+ id)))
5.541+ (when (> (1+ id) (fill-pointer *classes*))
5.542+ (setf (fill-pointer *classes*) (1+ id)))
5.543+ (setf (aref *classes* id) class))
5.544+
5.545+(defmethod write-object ((class storable-class) stream)
5.546+ (cond ((position class *classes* :test #'eq))
5.547+ (t
5.548+ (unless (class-finalized-p class)
5.549+ (finalize-inheritance class))
5.550+ (let ((id (vector-push-extend class *classes*))
5.551+ (slots (slots-to-store class)))
5.552+ (write-n-bytes #.(type-code 'storable-class) 1 stream)
5.553+ (write-object (class-name class) stream)
5.554+ (write-n-bytes id +class-id-length+ stream)
5.555+ (write-n-bytes (length slots) +sequence-length+ stream)
5.556+ (loop for slot across slots
5.557+ do (write-object (slot-definition-name slot)
5.558+ stream))
5.559+ id))))
5.560+
5.561+(defreader storable-class (stream)
5.562+ (let ((class (find-class (read-next-object stream))))
5.563+ (cache-class class
5.564+ (read-n-bytes +class-id-length+ stream))
5.565+ (unless (class-finalized-p class)
5.566+ (finalize-inheritance class))
5.567+ (let* ((length (read-n-bytes +sequence-length+ stream))
5.568+ (vector (make-array length)))
5.569+ (loop for i below length
5.570+ for slot-d =
5.571+ (slot-effective-definition class (read-next-object stream))
5.572+ when slot-d
5.573+ do (setf (aref vector i)
5.574+ (cons (slot-definition-location slot-d)
5.575+ (slot-definition-initform slot-d))))
5.576+ (setf (slot-locations-and-initforms class) vector))
5.577+ (read-next-object stream)))
5.578+
5.579+;;; Storable ID
5.580+
5.581+(defmethod write-object ((object id) stream)
5.582+ (cond ((written object)
5.583+ (let* ((class (class-of object))
5.584+ (class-id (write-object class stream)))
5.585+ (write-n-bytes #.(type-code 'id) 1 stream)
5.586+ (write-n-bytes class-id +class-id-length+ stream)
5.587+ (write-n-bytes (id object) +id-length+ stream)))
5.588+ (t
5.589+ (write-storable-object object stream))))
5.590+
5.591+(defun get-class (id)
5.592+ (aref *classes* id))
5.593+
5.594+(declaim (inline get-instance))
5.595+(defun get-instance (class-id id)
5.596+ (let* ((class (get-class class-id))
5.597+ (index (if (typep class 'storable-class)
5.598+ (id-cache class)
5.599+ *indexes*)))
5.600+ (or (gethash id index)
5.601+ (setf (gethash id index)
5.602+ (fast-allocate-instance class)))))
5.603+
5.604+(defreader id (stream)
5.605+ (get-instance (read-n-bytes +class-id-length+ stream)
5.606+ (read-n-bytes +id-length+ stream)))
5.607+
5.608+;;; storable-object
5.609+;; Can't use write-object method, because it would conflict with
5.610+;; writing a pointer to a standard object
5.611+(defun write-storable-object (object stream)
5.612+ (let* ((class (class-of object))
5.613+ (slots (slot-locations-and-initforms class))
5.614+ (class-id (write-object class stream)))
5.615+ (declare (simple-vector slots))
5.616+ (write-n-bytes #.(type-code 'storable-object) 1 stream)
5.617+ (write-n-bytes class-id +class-id-length+ stream)
5.618+ (unless (id object)
5.619+ (setf (id object) (last-id *collection*))
5.620+ (incf (last-id *collection*)))
5.621+ (write-n-bytes (id object) +id-length+ stream)
5.622+ (setf (written object) t)
5.623+ (loop for id below (length slots)
5.624+ for (location . initform) = (aref slots id)
5.625+ for value = (standard-instance-access object location)
5.626+ unless (eql value initform)
5.627+ do
5.628+ (write-n-bytes id 1 stream)
5.629+ (if (eq value '+slot-unbound+)
5.630+ (write-n-bytes +unbound-slot+ 1 stream)
5.631+ (write-object value stream)))
5.632+ (write-n-bytes +end+ 1 stream)))
5.633+
5.634+(defreader storable-object (stream)
5.635+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
5.636+ (id (read-n-bytes +id-length+ stream))
5.637+ (instance (get-instance class-id id))
5.638+ (class (class-of instance))
5.639+ (slots (slot-locations-and-initforms class)))
5.640+ (declare (simple-vector slots))
5.641+ (setf (id instance) id)
5.642+ (if (>= id (last-id *collection*))
5.643+ (setf (last-id *collection*) (1+ id)))
5.644+ (loop for slot-id = (read-n-bytes 1 stream)
5.645+ until (= slot-id +end+)
5.646+ do
5.647+ (setf (standard-instance-access instance
5.648+ (car (aref slots slot-id)))
5.649+ (let ((code (read-n-bytes 1 stream)))
5.650+ (if (= code +unbound-slot+)
5.651+ '+slot-unbound+
5.652+ (call-reader code stream)))))
5.653+ instance))
5.654+
5.655+;;; standard-class
5.656+
5.657+(defmethod write-object ((class standard-class) stream)
5.658+ (cond ((position class *classes* :test #'eq))
5.659+ (t
5.660+ (unless (class-finalized-p class)
5.661+ (finalize-inheritance class))
5.662+ (let ((id (vector-push-extend class *classes*))
5.663+ (slots (class-slots class)))
5.664+ (write-n-bytes #.(type-code 'standard-class) 1 stream)
5.665+ (write-object (class-name class) stream)
5.666+ (write-n-bytes id +class-id-length+ stream)
5.667+ (write-n-bytes (length slots) +sequence-length+ stream)
5.668+ (loop for slot in slots
5.669+ do (write-object (slot-definition-name slot)
5.670+ stream))
5.671+ id))))
5.672+
5.673+(defreader standard-class (stream)
5.674+ (let ((class (find-class (read-next-object stream))))
5.675+ (cache-class class
5.676+ (read-n-bytes +class-id-length+ stream))
5.677+ (unless (class-finalized-p class)
5.678+ (finalize-inheritance class))
5.679+ (let ((length (read-n-bytes +sequence-length+ stream)))
5.680+ (loop for i below length
5.681+ do (slot-effective-definition class (read-next-object stream))
5.682+ ;;do (setf (aref vector i)
5.683+ ;; (cons (slot-definition-location slot-d)
5.684+ ;; (slot-definition-initform slot-d)))
5.685+ ))
5.686+ (read-next-object stream)))
5.687+
5.688+;;; standard-link
5.689+
5.690+(defun write-standard-link (object stream)
5.691+ (let* ((class (class-of object))
5.692+ (class-id (write-object class stream)))
5.693+ (write-n-bytes #.(type-code 'standard-link) 1 stream)
5.694+ (write-n-bytes class-id +class-id-length+ stream)
5.695+ (write-n-bytes (get-object-id object) +id-length+ stream)))
5.696+
5.697+(defreader standard-link (stream)
5.698+ (get-instance (read-n-bytes +class-id-length+ stream)
5.699+ (read-n-bytes +id-length+ stream)))
5.700+
5.701+;;; standard-object
5.702+
5.703+(defun get-object-id (object)
5.704+ (let ((cache (object-cache *collection*)))
5.705+ (or (gethash object cache)
5.706+ (prog1
5.707+ (setf (gethash object cache)
5.708+ (last-id *collection*))
5.709+ (incf (last-id *collection*))))))
5.710+
5.711+(defmethod write-object ((object standard-object) stream)
5.712+ (if (gethash object *written-objects*)
5.713+ (write-standard-link object stream)
5.714+ (let* ((class (class-of object))
5.715+ (slots (class-slots class))
5.716+ (class-id (write-object class stream)))
5.717+ (write-n-bytes #.(type-code 'standard-object) 1 stream)
5.718+ (write-n-bytes class-id +class-id-length+ stream)
5.719+ (write-n-bytes (get-object-id object) +id-length+ stream)
5.720+ (setf (gethash object *written-objects*) t)
5.721+ (loop for id from 0
5.722+ for slot in slots
5.723+ for location = (slot-definition-location slot)
5.724+ for initform = (slot-definition-initform slot)
5.725+ for value = (standard-instance-access object location)
5.726+ do
5.727+ (write-n-bytes id 1 stream)
5.728+ (if (eq value '+slot-unbound+)
5.729+ (write-n-bytes +unbound-slot+ 1 stream)
5.730+ (write-object value stream)))
5.731+ (write-n-bytes +end+ 1 stream))))
5.732+
5.733+(defreader standard-object (stream)
5.734+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
5.735+ (id (read-n-bytes +id-length+ stream))
5.736+ (instance (get-instance class-id id))
5.737+ (class (class-of instance))
5.738+ (slots (class-slots class)))
5.739+ (flet ((read-slot ()
5.740+ (let ((code (read-n-bytes 1 stream)))
5.741+ (if (= code +unbound-slot+)
5.742+ '+slot-unbound+
5.743+ (call-reader code stream)))))
5.744+ (loop for slot-id = (read-n-bytes 1 stream)
5.745+ until (= slot-id +end+)
5.746+ do
5.747+ (let ((slot (nth slot-id slots)))
5.748+ (if slot
5.749+ (setf (standard-instance-access instance
5.750+ (slot-definition-location slot))
5.751+ (read-slot))
5.752+ (read-slot)))))
5.753+ instance))
5.754+
5.755+;;; collection
5.756+
5.757+(defmethod write-object ((collection collection) stream)
5.758+ (write-n-bytes #.(type-code 'collection) 1 stream))
5.759+
5.760+(defreader collection (stream)
5.761+ (declare (ignore stream))
5.762+ *collection*)
5.763+
5.764+;;;
5.765+#+sbcl (declaim (inline %fast-allocate-instance))
5.766+
5.767+#+sbcl
5.768+(defun %fast-allocate-instance (wrapper initforms)
5.769+ (declare (simple-vector initforms))
5.770+ (let ((instance (sb-pcl::make-instance->constructor-call
5.771+ (copy-seq initforms) (sb-pcl::safe-code-p))))
5.772+ (setf (sb-pcl::std-instance-slots instance)
5.773+ wrapper)
5.774+ instance))
5.775+
5.776+#+sbcl
5.777+(defun fast-allocate-instance (class)
5.778+ (declare (optimize speed))
5.779+ (if (typep class 'storable-class)
5.780+ (let ((initforms (class-initforms class))
5.781+ (wrapper (sb-pcl::class-wrapper class)))
5.782+ (%fast-allocate-instance wrapper initforms))
5.783+ (allocate-instance class)))
5.784+
5.785+(defun clear-cache (collection)
5.786+ (setf (classes collection) (make-class-cache)
5.787+ (packages collection) (make-s-packages)))
5.788+
5.789+(defun read-file (function file)
5.790+ (with-io-file (stream file)
5.791+ (loop until (stream-end-of-file-p stream)
5.792+ do (let ((object (read-next-object stream)))
5.793+ (when (and (not (typep object 'class))
5.794+ (typep object 'standard-object))
5.795+ (funcall function object))))))
5.796+
5.797+(defun load-data (collection file function)
5.798+ (with-collection collection
5.799+ (read-file function file)))
5.800+
5.801+(defun save-data (collection &optional file)
5.802+ (let ((*written-objects* (make-hash-table :test 'eq)))
5.803+ (clear-cache collection)
5.804+ (with-collection collection
5.805+ (with-io-file (stream file
5.806+ :direction :output)
5.807+ (dump-data stream)))
5.808+ (clear-cache collection)
5.809+ (values)))
5.810+
5.811+(defun save-doc (collection document &optional file)
5.812+ (let ((*written-objects* (make-hash-table :test 'eq)))
5.813+ (with-collection collection
5.814+ (with-io-file (stream file
5.815+ :direction :output
5.816+ :append t)
5.817+ (write-top-level-object document stream)))))
5.818+
5.819+;;; DB Functions
5.820+
5.821+(defmethod sum ((collection collection) &key function element)
5.822+ (let* ((sum 0)
5.823+ (function (or function
5.824+ (lambda (doc)
5.825+ (incf sum (get-val doc element))))))
5.826+ (map-docs nil
5.827+ function
5.828+ collection)
5.829+ sum))
5.830+
5.831+(defmethod max-val ((collection collection) &key function element)
5.832+ (let* ((max 0)
5.833+ (function (or function
5.834+ (lambda (doc)
5.835+ (if (get-val doc element)
5.836+ (if (> (get-val doc element) max)
5.837+ (setf max (get-val doc element))))))))
5.838+ (map-docs nil
5.839+ function
5.840+ collection)
5.841+ max))
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/examples/db/xdb/document.lisp Sun Jun 16 22:15:04 2024 -0400
6.3@@ -0,0 +1,67 @@
6.4+;;; obj/db/document.lisp --- Database Document Objects
6.5+
6.6+;; Spliced from XDB, currently not in use outside of it
6.7+
6.8+;;; Code:
6.9+(in-package :xdb)
6.10+;;; Document
6.11+(defclass document ()
6.12+ ((collection :initarg :collection
6.13+ :accessor collection)
6.14+ (key :initarg :key
6.15+ :accessor key)
6.16+ (doc-type :initarg :doc-type
6.17+ :initform nil
6.18+ :accessor doc-type)))
6.19+
6.20+(defmethod duplicate-doc-p ((doc document) test-doc)
6.21+ (or (eq doc test-doc)
6.22+ (equal (key doc) (key test-doc))))
6.23+
6.24+(defmethod add ((doc document) &key collection duplicate-doc-p-func)
6.25+ (when doc
6.26+ (if (slot-boundp doc 'collection)
6.27+ (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p))
6.28+ (error "Must specify collection to add document to."))))
6.29+
6.30+(defmethod get-val ((doc document) element &optional data-type)
6.31+ (declare (ignore data-type))
6.32+ (if (slot-boundp doc element)
6.33+ (slot-val doc element)))
6.34+
6.35+(defmethod (setf get-val) (new-value (doc document) element &optional data-type)
6.36+ (declare (ignore data-type))
6.37+ (if doc
6.38+ (setf (slot-value doc element) new-value)))
6.39+
6.40+(defclass document-join (join-docs)
6.41+ ())
6.42+
6.43+(defclass document-join-result (join-result)
6.44+ ())
6.45+
6.46+(defmethod get-val ((composite-doc document-join-result) element &optional data-type)
6.47+ (declare (ignore data-type))
6.48+ (map 'list
6.49+ (lambda (doc)
6.50+ (cons (doc-type doc) (get-val doc element)))
6.51+ (docs composite-doc)))
6.52+
6.53+
6.54+(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal))
6.55+ (map-docs
6.56+ nil
6.57+ (lambda (doc)
6.58+ (when (apply test (get-val doc element) value)
6.59+ (return-from get-doc doc)))
6.60+ collection))
6.61+
6.62+
6.63+(defmethod find-doc ((collection document-join) &key test)
6.64+ (if test
6.65+ (map-docs
6.66+ nil
6.67+ (lambda (doc)
6.68+ (when (apply test doc)
6.69+ (return-from find-doc doc)))
6.70+ collection)))
7.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2+++ b/examples/db/xdb/io.lisp Sun Jun 16 22:15:04 2024 -0400
7.3@@ -0,0 +1,265 @@
7.4+;;; io/blob.lisp --- Blob Database IO
7.5+
7.6+;;
7.7+
7.8+;;; Code:
7.9+(in-package :xdb)
7.10+
7.11+;;; IO
7.12+(defvar *fsync-data* nil)
7.13+
7.14+(defconstant +buffer-size+ 8192)
7.15+
7.16+(deftype word () 'sb-ext:word)
7.17+
7.18+(defstruct (input-stream
7.19+ (:predicate nil))
7.20+ (fd nil :type word)
7.21+ (left 0 :type word)
7.22+ (buffer-start (sb-sys:sap-int
7.23+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
7.24+ (+ +buffer-size+ 3))))
7.25+ :type word)
7.26+ (buffer-end 0 :type word)
7.27+ (buffer-position 0 :type word))
7.28+
7.29+(defstruct (output-stream
7.30+ (:predicate nil))
7.31+ (fd nil :type word)
7.32+ (buffer-start (sb-sys:sap-int
7.33+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
7.34+ (+ +buffer-size+ 3))))
7.35+ :type word)
7.36+ (buffer-end 0 :type word)
7.37+ (buffer-position 0 :type word))
7.38+
7.39+(defun open-file (file-stream
7.40+ &key direction)
7.41+ (if (eql direction :output)
7.42+ (let ((output (make-output-stream
7.43+ :fd (sb-sys:fd-stream-fd file-stream))))
7.44+ (setf (output-stream-buffer-position output)
7.45+ (output-stream-buffer-start output)
7.46+ (output-stream-buffer-end output)
7.47+ (+ (output-stream-buffer-start output)
7.48+ +buffer-size+))
7.49+ output)
7.50+ (make-input-stream
7.51+ :fd (sb-sys:fd-stream-fd file-stream)
7.52+ :left (file-length file-stream))))
7.53+
7.54+(defun close-input-stream (stream)
7.55+ (sb-alien:alien-funcall
7.56+ (sb-alien:extern-alien "free"
7.57+ (function (values) sb-alien:long))
7.58+ (input-stream-buffer-start stream)))
7.59+
7.60+(defun close-output-stream (stream)
7.61+ (flush-buffer stream)
7.62+ (sb-alien:alien-funcall
7.63+ (sb-alien:extern-alien "free"
7.64+ (function (values) sb-alien:long))
7.65+ (output-stream-buffer-start stream)))
7.66+
7.67+(declaim (inline stream-end-of-file-p))
7.68+(defun stream-end-of-file-p (stream)
7.69+ (and (>= (input-stream-buffer-position stream)
7.70+ (input-stream-buffer-end stream))
7.71+ (zerop (input-stream-left stream))))
7.72+
7.73+(declaim (inline sap-ref-24))
7.74+(defun sap-ref-24 (sap offset)
7.75+ (declare (optimize speed (safety 0))
7.76+ (fixnum offset))
7.77+ (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
7.78+
7.79+(declaim (inline n-sap-ref))
7.80+(defun n-sap-ref (n sap &optional (offset 0))
7.81+ (funcall (ecase n
7.82+ (1 #'sb-sys:sap-ref-8)
7.83+ (2 #'sb-sys:sap-ref-16)
7.84+ (3 #'sap-ref-24)
7.85+ (4 #'sb-sys:sap-ref-32))
7.86+ sap
7.87+ offset))
7.88+
7.89+(declaim (inline unix-read))
7.90+(defun unix-read (fd buf len)
7.91+ (declare (optimize (sb-c::float-accuracy 0)
7.92+ (space 0)))
7.93+ (declare (type sb-unix::unix-fd fd)
7.94+ (type word len))
7.95+ (sb-alien:alien-funcall
7.96+ (sb-alien:extern-alien "read"
7.97+ (function sb-alien:int
7.98+ sb-alien:int sb-alien:long sb-alien:int))
7.99+ fd buf len))
7.100+
7.101+(declaim (inline unix-read))
7.102+(defun unix-write (fd buf len)
7.103+ (declare (optimize (sb-c::float-accuracy 0)
7.104+ (space 0)))
7.105+ (declare (type sb-unix::unix-fd fd)
7.106+ (type word len))
7.107+ (sb-alien:alien-funcall
7.108+ (sb-alien:extern-alien "write"
7.109+ (function sb-alien:int
7.110+ sb-alien:int sb-alien:long sb-alien:int))
7.111+ fd buf len))
7.112+
7.113+(defun fill-buffer (stream offset)
7.114+ (let ((length (unix-read (input-stream-fd stream)
7.115+ (+ (input-stream-buffer-start stream) offset)
7.116+ (- +buffer-size+ offset))))
7.117+ (setf (input-stream-buffer-end stream)
7.118+ (+ (input-stream-buffer-start stream) (+ length offset)))
7.119+ (decf (input-stream-left stream) length))
7.120+ t)
7.121+
7.122+(defun refill-buffer (n stream)
7.123+ (declare (type word n)
7.124+ (input-stream stream))
7.125+ (let ((left-n-bytes (- (input-stream-buffer-end stream)
7.126+ (input-stream-buffer-position stream))))
7.127+ (when (> (- n left-n-bytes)
7.128+ (input-stream-left stream))
7.129+ (error "End of file ~a" stream))
7.130+ (unless (zerop left-n-bytes)
7.131+ (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
7.132+ (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
7.133+ (fill-buffer stream left-n-bytes))
7.134+ (let ((start (input-stream-buffer-start stream)))
7.135+ (setf (input-stream-buffer-position stream)
7.136+ (+ start n)))
7.137+ t)
7.138+
7.139+(declaim (inline advance-input-stream))
7.140+(defun advance-input-stream (n stream)
7.141+ (declare (optimize (space 0))
7.142+ (type word n)
7.143+ (type input-stream stream))
7.144+ (let* ((sap (input-stream-buffer-position stream))
7.145+ (new-sap (sb-ext:truly-the word (+ sap n))))
7.146+ (declare (word sap new-sap))
7.147+ (cond ((> new-sap (input-stream-buffer-end stream))
7.148+ (refill-buffer n stream)
7.149+ (sb-sys:int-sap (input-stream-buffer-start stream)))
7.150+ (t
7.151+ (setf (input-stream-buffer-position stream)
7.152+ new-sap)
7.153+ (sb-sys:int-sap sap)))))
7.154+
7.155+(declaim (inline read-n-bytes))
7.156+(defun read-n-bytes (n stream)
7.157+ (declare (optimize (space 0))
7.158+ (type word n))
7.159+ (n-sap-ref n (advance-input-stream n stream)))
7.160+
7.161+(declaim (inline read-n-signed-bytes))
7.162+(defun read-n-signed-bytes (n stream)
7.163+ (declare (optimize speed)
7.164+ (sb-ext:muffle-conditions sb-ext:compiler-note)
7.165+ (type (integer 1 4) n))
7.166+ (funcall (ecase n
7.167+ (1 #'sb-sys:signed-sap-ref-8)
7.168+ (2 #'sb-sys:signed-sap-ref-16)
7.169+ ;; (3 )
7.170+ (4 #'sb-sys:signed-sap-ref-32))
7.171+ (advance-input-stream n stream)
7.172+ 0))
7.173+
7.174+(declaim (inline write-n-signed-bytes))
7.175+(defun write-n-signed-bytes (value n stream)
7.176+ (declare (optimize speed)
7.177+ (sb-ext:muffle-conditions sb-ext:compiler-note)
7.178+ (fixnum n))
7.179+ (ecase n
7.180+ (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
7.181+ value))
7.182+ (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
7.183+ value))
7.184+ ;; (3 )
7.185+ (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
7.186+ value)))
7.187+ t)
7.188+
7.189+(defun flush-buffer (stream)
7.190+ (unix-write (output-stream-fd stream)
7.191+ (output-stream-buffer-start stream)
7.192+ (- (output-stream-buffer-position stream)
7.193+ (output-stream-buffer-start stream))))
7.194+
7.195+(declaim (inline advance-output-stream))
7.196+(defun advance-output-stream (n stream)
7.197+ (declare (optimize (space 0) (safety 0))
7.198+ (type word n)
7.199+ (type output-stream stream)
7.200+ ((integer 1 4) n))
7.201+ (let* ((sap (output-stream-buffer-position stream))
7.202+ (new-sap (sb-ext:truly-the word (+ sap n))))
7.203+ (declare (word sap new-sap))
7.204+ (cond ((> new-sap (output-stream-buffer-end stream))
7.205+ (flush-buffer stream)
7.206+ (setf (output-stream-buffer-position stream)
7.207+ (+ (output-stream-buffer-start stream)
7.208+ n))
7.209+ (sb-sys:int-sap (output-stream-buffer-start stream)))
7.210+ (t
7.211+ (setf (output-stream-buffer-position stream)
7.212+ new-sap)
7.213+ (sb-sys:int-sap sap)))))
7.214+
7.215+(declaim (inline write-n-bytes))
7.216+(defun write-n-bytes (value n stream)
7.217+ (declare (optimize (space 0))
7.218+ (type word n))
7.219+ (setf (sb-sys:sap-ref-32
7.220+ (advance-output-stream n stream)
7.221+ 0)
7.222+ value))
7.223+;;;
7.224+
7.225+(declaim (inline copy-mem))
7.226+(defun copy-mem (from to length)
7.227+ (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
7.228+ (loop for i by sb-vm:n-word-bytes below words-end
7.229+ do (setf (sb-sys:sap-ref-word to i)
7.230+ (sb-sys:sap-ref-word from i)))
7.231+ (loop for i from words-end below length
7.232+ do (setf (sb-sys:sap-ref-8 to i)
7.233+ (sb-sys:sap-ref-8 from i)))))
7.234+
7.235+(declaim (inline read-ascii-string-optimized))
7.236+(defun read-ascii-string-optimized (length string stream)
7.237+ (declare (type fixnum length)
7.238+ (optimize (speed 3))
7.239+ )
7.240+ (sb-sys:with-pinned-objects (string)
7.241+ (let ((sap (advance-input-stream length stream))
7.242+ (string-sap (sb-sys:vector-sap string)))
7.243+ (copy-mem sap string-sap length)))
7.244+ string)
7.245+(defmacro with-io-file ((stream file
7.246+ &key append (direction :input))
7.247+ &body body)
7.248+ (let ((fd-stream (gensym)))
7.249+ `(with-open-file (,fd-stream ,file
7.250+ :element-type '(unsigned-byte 8)
7.251+ :direction ,direction
7.252+ ,@(and (eql direction :output)
7.253+ `(:if-exists ,(if append
7.254+ :append
7.255+ :supersede)))
7.256+ ,@(and append
7.257+ `(:if-does-not-exist :create)))
7.258+ (let ((,stream (open-file ,fd-stream :direction ,direction)))
7.259+ (unwind-protect
7.260+ (progn ,@body)
7.261+ ,@(ecase direction
7.262+ (:output
7.263+ `((close-output-stream ,stream)
7.264+ (when *fsync-data*
7.265+ (sb-posix:fdatasync
7.266+ (sb-sys:fd-stream-fd ,fd-stream)))))
7.267+ (:input
7.268+ `((close-input-stream ,stream)))))))))
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/examples/db/xdb/pkg.lisp Sun Jun 16 22:15:04 2024 -0400
8.3@@ -0,0 +1,3 @@
8.4+(defpackage :xdb
8.5+ (:use :cl :std :seq :db :obj/meta/storable :obj/id)
8.6+ (:export :xdb :dbs :add-collection))
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/examples/db/xdb/proto.lisp Sun Jun 16 22:15:04 2024 -0400
9.3@@ -0,0 +1,86 @@
9.4+(in-package :xdb)
9.5+
9.6+(defgeneric initialize-doc-container (collection)
9.7+ (:documentation
9.8+ "Create the docs container and set the collection's docs to the container.
9.9+If you specialize this then you have to specialize add-doc, store-doc,
9.10+sort-collection, sort-collection-temporary and union-collection. "))
9.11+
9.12+(defgeneric map-docs (result-type function collection &rest more-collections)
9.13+ (:documentation
9.14+ "Applies the function accross all the documents in the collection"))
9.15+
9.16+(defgeneric duplicate-doc-p (doc test-doc)
9.17+ (:method ((a t) (b t))))
9.18+
9.19+(defgeneric find-duplicate-doc (collection doc &key function)
9.20+ (:documentation "Load collection from a file."))
9.21+
9.22+(defgeneric add-doc (collection doc &key duplicate-doc-p-func)
9.23+ (:documentation "Add a document to the docs container."))
9.24+
9.25+(defgeneric store-doc (collection doc &key duplicate-doc-p-func)
9.26+ (:documentation "Serialize the doc to file and add it to the collection."))
9.27+
9.28+(defgeneric serialize-doc (collection doc &key)
9.29+ (:documentation "Serialize the doc to file."))
9.30+
9.31+(defgeneric serialize-docs (collection &key duplicate-doc-p-func)
9.32+ (:documentation "Store all the docs in the collection on file and add it to the collection."))
9.33+
9.34+(defgeneric load-from-file (collection file)
9.35+ (:documentation "Load collection from a file."))
9.36+
9.37+(defgeneric get-collection (db name)
9.38+ (:documentation "Returns the collection by name."))
9.39+
9.40+(defgeneric add-collection (db name &key load-from-file-p)
9.41+ (:documentation "Adds a collection to the db."))
9.42+
9.43+(defgeneric snapshot (collection)
9.44+ (:documentation "Write out a snapshot."))
9.45+
9.46+(defgeneric load-db (db &key load-from-file-p)
9.47+ (:documentation "Loads all the collections in a location."))
9.48+
9.49+(defgeneric get-docs (db collection-name &key return-type &allow-other-keys)
9.50+ (:documentation "Returns the docs that belong to a collection."))
9.51+
9.52+(defgeneric get-doc (collection value &key element test)
9.53+ (:documentation "Returns the docs that belong to a collection."))
9.54+
9.55+(defgeneric get-doc-complex (test element value collection &rest more-collections)
9.56+ (:documentation "Returns the docs that belong to a collection."))
9.57+
9.58+(defgeneric get-doc-simple (element value collection &rest more-collections)
9.59+ (:documentation "Returns the docs that belong to a collection."))
9.60+
9.61+(defgeneric find-doc (collection &key test)
9.62+ (:documentation "Returns the docs that belong to a collection."))
9.63+
9.64+(defgeneric find-doc-complex (test collection &rest more-collections)
9.65+ (:documentation "Returns the first doc that matches the test."))
9.66+
9.67+(defgeneric find-docs (return-type test collection))
9.68+
9.69+(defgeneric union-collection (return-type collection &rest more-collections))
9.70+
9.71+(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func)
9.72+ (:documentation "This sorts the collection 'permanantly'."))
9.73+
9.74+(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func)
9.75+ (:documentation "This does not sort the actual collection but returns an array
9.76+of sorted docs."))
9.77+
9.78+(defgeneric sum (collection &key function &allow-other-keys)
9.79+ (:documentation "Applies the function to all the docs in the collection and returns the sum of
9.80+the return values."))
9.81+
9.82+(defgeneric max-val (collection &key function element))
9.83+
9.84+;;; Document
9.85+(defgeneric add (doc &key collection duplicate-doc-p-func)
9.86+ (:documentation "Add a document to the docs container."))
9.87+
9.88+;;; Disk
9.89+(defgeneric write-object (object stream))
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/examples/db/xdb/tests.lisp Sun Jun 16 22:15:04 2024 -0400
10.3@@ -0,0 +1,231 @@
10.4+(defpackage :xdb/tests
10.5+ (:use :cl :rt :obj/db :obj/id :xdb :obj/meta/storable))
10.6+
10.7+(in-package :xdb/tests)
10.8+(defsuite :xdb)
10.9+(in-suite :xdb)
10.10+
10.11+(defparameter *tree* nil)
10.12+
10.13+(defclass test-doc-non-storable (id)
10.14+ ((eid :initarg :eid)
10.15+ (aa :initarg :aa)
10.16+ (bb :initarg :bb)
10.17+ (cc :initarg :cc)
10.18+ (dd :initarg :dd)
10.19+ (ee :initarg :ee)
10.20+ (ff :initarg :ff)
10.21+ (hh :initarg :hh)
10.22+ (data :initarg :data
10.23+ :initform (make-hash-table)
10.24+ :accessor data)
10.25+ (key :initarg :key
10.26+ :initform nil
10.27+ :accessor key)
10.28+ (type :initarg :type
10.29+ :initform nil)))
10.30+
10.31+(defclass test-doc-storable ()
10.32+ ((eid :initarg :eid)
10.33+ (aa :initarg :aa)
10.34+ (bb :initarg :bb)
10.35+ (cc :initarg :cc)
10.36+ (dd :initarg :dd)
10.37+ (ee :initarg :ee)
10.38+ (ff :initarg :ff)
10.39+ (hh :initarg :hh)
10.40+ (data :initarg :data
10.41+ :initform (make-hash-table)
10.42+ :accessor data)
10.43+ (key :initarg :key
10.44+ :initform nil
10.45+ :accessor key)
10.46+ (type :initarg :type
10.47+ :initform nil))
10.48+ (:metaclass storable-class))
10.49+
10.50+(defun make-doc-test (type key data)
10.51+ (let ((doc-obj (make-instance 'test-doc-storable :key key :type type)))
10.52+ (dolist (pair data)
10.53+ (setf (gethash (first pair) (data doc-obj)) (second pair)))
10.54+ doc-obj))
10.55+
10.56+(defun test-store-doc (collection times)
10.57+ (dotimes (i times)
10.58+ (xdb::store-doc collection
10.59+ (make-doc-test
10.60+ "Test Doc"
10.61+ i
10.62+ (list
10.63+ (list "id" i)
10.64+ (list "eid" i)
10.65+ (list "aa" (format nil "~R" (random 51234)))
10.66+ (list "bb" (format nil "~R" (random 1234)))
10.67+ (list "cc" (format nil "~R" (random 1234)))
10.68+ (list "dd" (format nil "~R" (random 1234)))
10.69+ (list "ee" (format nil "~R" (random 1234)))
10.70+ (list "ff" (format nil "~R" (random 1234)))
10.71+ (list "gg" (format nil "~R" (random 1234)))
10.72+ (list "hh" (format nil "~R" (random 1234))))))))
10.73+
10.74+(defun db-test (n)
10.75+ (let* ((db (make-instance 'xdb :location "/tmp/db-test/"))
10.76+ (col (add-collection db "test" :load-from-file-p nil)))
10.77+ (time (test-store-doc col n))
10.78+ ;; (time (snapshot db))
10.79+ ;; (time (sum col "eid"))
10.80+ ;; (time (find-doc col "eid" 50))
10.81+ ;; (time (sort-collection col))
10.82+ ))
10.83+
10.84+(defun test-store-docx (collection times)
10.85+ (dotimes (i times)
10.86+
10.87+ (xdb::store-doc collection
10.88+
10.89+ (make-doc-test
10.90+ "Test Doc"
10.91+ i
10.92+ (list
10.93+ (list "id" i)
10.94+ (list "eid" i)
10.95+ (list "aa" (random 51234))
10.96+ (list "bb" (format nil "~R" (random 1234)))
10.97+ (list "cc" (format nil "~R" (random 1234)))
10.98+ (list "dd" (format nil "~R" (random 1234)))
10.99+ (list "ee" (format nil "~R" (random 1234)))
10.100+ (list "ff" (format nil "~R" (random 1234)))
10.101+ (list "gg" (format nil "~R" (random 1234)))
10.102+ (list "hh" (get-universal-time))))
10.103+ )
10.104+
10.105+ (if (equal (mod i 100000) 0)
10.106+ (sb-ext:gc :full t))))
10.107+
10.108+(defun test-store-doc-storable-object (collection times)
10.109+ (dotimes (i times)
10.110+ (xdb::store-doc collection
10.111+ (make-instance 'test-doc-storable :key i :type "Test Doc"
10.112+ :id i
10.113+ :eid i
10.114+ :aa (random 51234)
10.115+ :bb (format nil "~R" (random 1234))
10.116+ :cc (format nil "~R" (random 1234))
10.117+ :dd (format nil "~R" (random 1234))
10.118+ :ee (format nil "~R" (random 1234))
10.119+ :ff (format nil "~R" (random 1234))
10.120+ :hh (get-universal-time))
10.121+
10.122+ )
10.123+
10.124+ (if (equal (mod i 100000) 0)
10.125+ (sb-ext:gc :full t))))
10.126+
10.127+(defun test-store-doc-non-storable-object (collection times)
10.128+ (dotimes (i times)
10.129+ (xdb::store-doc collection
10.130+ (make-instance 'test-doc-non-storable :key i :type "Test Doc"
10.131+ :id i
10.132+ :eid i
10.133+ :aa (random 51234)
10.134+ :bb (format nil "~R" (random 1234))
10.135+ :cc (format nil "~R" (random 1234))
10.136+ :dd (format nil "~R" (random 1234))
10.137+ :ee (format nil "~R" (random 1234))
10.138+ :ff (format nil "~R" (random 1234))
10.139+ :hh (get-universal-time))
10.140+
10.141+ )
10.142+
10.143+ (if (equal (mod i 100000) 0)
10.144+ (sb-ext:gc :full t))))
10.145+
10.146+(defun test-store-doc-hash (collection times)
10.147+ (dotimes (i times)
10.148+ (let ((hash (make-hash-table :test 'equal)))
10.149+ (setf (gethash 'key hash) i)
10.150+ (setf (gethash "id" hash) i)
10.151+ (setf (gethash "eid" hash) i)
10.152+ (setf (gethash "bb" hash) (format nil "~R" (random 1234)))
10.153+ (setf (gethash "cc" hash) (format nil "~R" (random 1234)))
10.154+ (setf (gethash "dd" hash) (format nil "~R" (random 1234)))
10.155+ (setf (gethash "ee" hash) (format nil "~R" (random 1234)))
10.156+ (setf (gethash "ff" hash) (format nil "~R" (random 1234)))
10.157+ (setf (gethash "stamp" hash) (get-universal-time))
10.158+ (xdb::store-doc collection hash))
10.159+
10.160+ (if (equal (mod i 100000) 0)
10.161+ (sb-ext:gc :full t))))
10.162+
10.163+
10.164+(defun test-store-doc-list (collection times)
10.165+ (dotimes (i times)
10.166+ (xdb::store-doc collection (list
10.167+ (list 'key i)
10.168+ (list "id" i)
10.169+ (list "eid" i)
10.170+ (list "aa" (random 51234))
10.171+ (list "bb" (format nil "~R" (random 1234)))
10.172+ (list "cc" (format nil "~R" (random 1234)))
10.173+ (list "dd" (format nil "~R" (random 1234)))
10.174+ (list "ee" (format nil "~R" (random 1234)))
10.175+ (list "ff" (format nil "~R" (random 1234)))
10.176+ (list "gg" (format nil "~R" (random 1234)))
10.177+ (list "stamp" (get-universal-time))))
10.178+
10.179+ (if (equal (mod i 100000) 0)
10.180+ (sb-ext:gc :full t))))
10.181+
10.182+(defparameter db (make-instance 'xdb :location "/tmp/db-test/"))
10.183+
10.184+(defparameter col-hash (add-collection db "test-hash" :load-from-file-p nil))
10.185+
10.186+(defparameter col-list (add-collection db "test-list" :load-from-file-p nil))
10.187+(defparameter col-object (add-collection db "test-object" :load-from-file-p nil))
10.188+(defparameter col-object-storable (add-collection db "test-object-storable" :load-from-file-p nil))
10.189+
10.190+;;; DB
10.191+(deftest db ()
10.192+ "Test database protocol."
10.193+ (format t "Hash Test~%")
10.194+ (format t "Store~%")
10.195+ (time (test-store-doc-hash col-hash 10000))
10.196+ (format t "Sum~%")
10.197+ (time (xdb::sum col-hash :element "id"))
10.198+ (format t "Find~%")
10.199+ (time (xdb::find-doc col-hash :test (lambda (doc) (equal (get-val doc "id") 500))))
10.200+ (format t "Sort~%")
10.201+ (time (xdb::sort-collection col-hash))
10.202+ (format t "List Test~%")
10.203+ (format t "Store~%")
10.204+ (time (test-store-doc-list col-list 10000))
10.205+ (format t "Sum~%")
10.206+ (time (xdb::sum col-list :element "id"))
10.207+ (format t "Find~%")
10.208+ (time (xdb::find-doc col-list :test (lambda (doc) (equal (get-val doc "id") 500))))
10.209+ (format t "Sort~%")
10.210+ (time (xdb::sort-collection col-list))
10.211+
10.212+
10.213+ (format t "Object non storable Test~%")
10.214+ (format t "Store~%")
10.215+ (time (test-store-doc-non-storable-object col-object 10000))
10.216+ (format t "Sum~%")
10.217+ (time (xdb::sum col-object :element 'id))
10.218+ (format t "Find~%")
10.219+ (time (xdb::find-doc col-object :test (lambda (doc) (equal (get-val doc 'id) 500))))
10.220+ (format t "Sort~%")
10.221+ (time (xdb::sort-collection col-object))
10.222+
10.223+
10.224+ (setf xdb::*fsync-data* nil)
10.225+ (format t "Object storable Test~%")
10.226+ (format t "Store~%")
10.227+ (time (test-store-doc-storable-object col-object-storable 10000))
10.228+ (format t "Sum~%")
10.229+ (time (xdb::sum col-object-storable :element 'id))
10.230+ (format t "Find~%")
10.231+ (time (xdb::find-doc col-object-storable :test (lambda (doc) (equal (get-val doc 'id) 500))))
10.232+ (format t "Sort~%")
10.233+ (time (xdb::sort-collection col-object-storable)))
10.234+
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/examples/db/xdb/xdb.asd Sun Jun 16 22:15:04 2024 -0400
11.3@@ -0,0 +1,14 @@
11.4+(defsystem :xdb
11.5+ :depends-on (:std :obj)
11.6+ :serial t
11.7+ :components ((:file "pkg")
11.8+ (:file "io")
11.9+ (:file "disk")
11.10+ (:file "document")
11.11+ (:file "xdb"))
11.12+ :in-order-to ((test-op (test-op "xdb/tests"))))
11.13+
11.14+(defsystem :xdb/tests
11.15+ :depends-on (:rt :obj :xdb)
11.16+ :components ((:file "tests"))
11.17+ :perform (test-op (o c) (symbol-call :rt :do-tests :xdb)))
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/examples/db/xdb/xdb.lisp Sun Jun 16 22:15:04 2024 -0400
12.3@@ -0,0 +1,292 @@
12.4+(in-package :xdb)
12.5+
12.6+;;; XDB
12.7+(defclass xdb ()
12.8+ ((location :initarg :location
12.9+ :accessor location
12.10+ :initform (required-argument "Location is required"))
12.11+ (collections :initarg :collections
12.12+ :accessor collections
12.13+ :initform (make-hash-table :test 'equal))))
12.14+
12.15+(defclass dbs ()
12.16+ ((databases :initarg :databases
12.17+ :accessor databases
12.18+ :initform (make-hash-table :test 'equal))
12.19+ (base-path :initarg :base-path
12.20+ :initform "/tmp/db/"
12.21+ :accessor base-path)))
12.22+
12.23+(defmethod get-db ((dbs dbs) name)
12.24+ (gethash name (databases dbs)))
12.25+
12.26+(defun parse-db-path (path)
12.27+ (make-pathname :directory
12.28+ (list* :relative
12.29+ (etypecase path
12.30+ (cons path
12.31+ path)
12.32+ (string path
12.33+ (list path))))))
12.34+
12.35+(defmethod add-db ((dbs dbs) name &key base-path load-from-file-p)
12.36+ (unless (gethash name (databases dbs))
12.37+ (let* ((base-path (or base-path (base-path dbs)))
12.38+ (db-path (merge-pathnames (parse-db-path name) base-path))
12.39+ (db (make-instance 'xdb :location db-path)))
12.40+ (ensure-directories-exist db-path)
12.41+ (setf (gethash name (databases dbs)) db)
12.42+ (if load-from-file-p
12.43+ (load-db db :load-from-file-p load-from-file-p)))))
12.44+
12.45+(defparameter *dbs* nil)
12.46+
12.47+(defun dbs ()
12.48+ *dbs*)
12.49+
12.50+(defmethod initialize-doc-container ((collection collection))
12.51+ (setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0)))
12.52+
12.53+(defmethod map-docs (result-type function (collection collection)
12.54+ &rest more-collections)
12.55+ (let ((result
12.56+ (map result-type function (docs collection))))
12.57+ (loop for collection in more-collections
12.58+ for results = (map result-type function (docs collection))
12.59+ if result-type
12.60+ do (setf result (concatenate result-type result results)))
12.61+ result))
12.62+
12.63+(defmethod find-duplicate-doc ((collection collection) doc &key function)
12.64+ (let ((test (or function #'duplicate-doc-p)))
12.65+ (map-docs
12.66+ nil
12.67+ (lambda (docx)
12.68+ (when (funcall test doc docx)
12.69+ (return-from find-duplicate-doc docx)))
12.70+ collection)))
12.71+
12.72+(defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func)
12.73+ (when doc
12.74+ (if duplicate-doc-p-func
12.75+ (let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func)))
12.76+ (if (not dup)
12.77+ (vector-push-extend doc (docs collection))
12.78+ (setf dup doc) ;;doing this because
12.79+ ))
12.80+ (vector-push-extend doc (docs collection)))))
12.81+
12.82+(defmethod store-doc ((collection collection) doc
12.83+ &key (duplicate-doc-p-func #'duplicate-doc-p))
12.84+ (let ((dup (and duplicate-doc-p-func
12.85+ (find-duplicate-doc collection doc
12.86+ :function duplicate-doc-p-func))))
12.87+ ;; a document might be considered duplicate based on the data
12.88+ ;;contained and not its eql status as lisp object so we have to replace
12.89+ ;;it in the array with the new object effectively updating the data.
12.90+ (if dup
12.91+ (setf dup doc)
12.92+ (vector-push-extend doc (docs collection)))
12.93+ (serialize-doc collection doc))
12.94+ collection)
12.95+
12.96+(defmethod serialize-doc ((collection collection) doc &key)
12.97+ (let ((path (make-pathname :type "log" :defaults (db::path collection))))
12.98+ (ensure-directories-exist path)
12.99+ (db::save-doc collection doc path))
12.100+ doc)
12.101+
12.102+(defmethod serialize-docs (collection &key duplicate-doc-p-func)
12.103+ (map-docs
12.104+ nil
12.105+ (lambda (doc)
12.106+ (store-doc collection doc
12.107+ :duplicate-doc-p-func duplicate-doc-p-func))
12.108+ collection))
12.109+
12.110+(defmethod load-from-file ((collection collection) file)
12.111+ (when (probe-file file)
12.112+ (db::load-data collection file
12.113+ (lambda (object)
12.114+ (add-doc collection object)))))
12.115+
12.116+(defmethod get-collection ((db xdb) name)
12.117+ (gethash name (collections db)))
12.118+
12.119+(defun make-new-collection (name db &key collection-class)
12.120+ (let ((collection
12.121+ (make-instance collection-class
12.122+ :name name
12.123+ :path (merge-pathnames name (location db)))))
12.124+ (initialize-doc-container collection)
12.125+ collection))
12.126+
12.127+(defmethod add-collection ((db xdb) name
12.128+ &key (collection-class 'collection) load-from-file-p)
12.129+ (let ((collection (or (gethash name (collections db))
12.130+ (setf (gethash name (collections db))
12.131+ (make-new-collection name db
12.132+ :collection-class collection-class)))))
12.133+ (ensure-directories-exist (db::path collection))
12.134+ (when load-from-file-p
12.135+ (load-from-file collection
12.136+ (make-pathname :defaults (db::path collection)
12.137+ :type "snap"))
12.138+ (load-from-file collection
12.139+ (make-pathname :defaults (db::path collection)
12.140+ :type "log")))
12.141+ collection))
12.142+
12.143+(defun append-date (name)
12.144+ (format nil "~a-~a" name (file-date)))
12.145+
12.146+(defmethod snapshot ((collection collection))
12.147+ (let* ((backup (merge-pathnames "backup/" (db::path collection)))
12.148+ (log (make-pathname :type "log" :defaults (db::path collection)))
12.149+ (snap (make-pathname :type "snap" :defaults (db::path collection)))
12.150+ (backup-name (append-date (db::name collection)))
12.151+ (log-backup (make-pathname :name backup-name
12.152+ :type "log"
12.153+ :defaults backup))
12.154+ (snap-backup (make-pathname :name backup-name
12.155+ :type "snap"
12.156+ :defaults backup)))
12.157+ (ensure-directories-exist backup)
12.158+ (when (probe-file snap)
12.159+ (rename-file snap snap-backup))
12.160+ (when (probe-file log)
12.161+ (rename-file log log-backup))
12.162+ (db::save-data collection snap)))
12.163+
12.164+(defmethod snapshot ((db xdb))
12.165+ (maphash (lambda (key value)
12.166+ (declare (ignore key))
12.167+ (snapshot value))
12.168+ (collections db)))
12.169+
12.170+(defmethod load-db ((db xdb) &key load-from-file-p)
12.171+ (let ((unique-collections (make-hash-table :test 'equal)))
12.172+ (dolist (path (directory (format nil "~A/*.*" (location db))))
12.173+ (when (pathname-name path)
12.174+ (setf (gethash (pathname-name path) unique-collections)
12.175+ (pathname-name path))))
12.176+ (maphash #'(lambda (key value)
12.177+ (declare (ignore key))
12.178+ (add-collection db value :load-from-file-p load-from-file-p))
12.179+ unique-collections)))
12.180+
12.181+(defmethod get-docs ((db xdb) collection-name &key return-type)
12.182+ (let ((col (gethash collection-name (collections db))))
12.183+ (if return-type
12.184+ (coerce return-type
12.185+ (docs col))
12.186+ (docs col))))
12.187+
12.188+(defmethod get-doc (collection value &key (element 'key) (test #'equal))
12.189+ (map-docs
12.190+ nil
12.191+ (lambda (doc)
12.192+ (when (funcall test (get-val doc element) value)
12.193+ (return-from get-doc doc)))
12.194+ collection))
12.195+
12.196+(defmethod get-doc-complex (test element value collection &rest more-collections)
12.197+ (apply #'map-docs
12.198+ nil
12.199+ (lambda (doc)
12.200+ (when (apply test (list (get-val doc element) value))
12.201+ (return-from get-doc-complex doc)))
12.202+ collection
12.203+ more-collections))
12.204+
12.205+(defmethod find-doc (collection &key test)
12.206+ (if test
12.207+ (map-docs
12.208+ nil
12.209+ (lambda (doc)
12.210+ (when (funcall test doc)
12.211+ (return-from find-doc doc)))
12.212+ collection)))
12.213+
12.214+(defmethod find-doc-complex (test collection &rest more-collections)
12.215+ (apply #'map-docs
12.216+ (lambda (doc)
12.217+ (when (funcall test doc)
12.218+ (return-from find-doc-complex doc)))
12.219+ collection
12.220+ (cdr more-collections)))
12.221+
12.222+(defmethod find-docs (return-type test collection)
12.223+ (coerce (loop for doc across (docs collection)
12.224+ when (funcall test doc)
12.225+ collect doc)
12.226+ return-type))
12.227+
12.228+(defclass union-docs ()
12.229+ ((docs :initarg :docs
12.230+ :accessor :docs)))
12.231+
12.232+(defmethod union-collection (return-type (collection collection) &rest more-collections)
12.233+ (make-instance
12.234+ 'union-docs
12.235+ :docs (apply #'map-docs (list return-type collection more-collections))))
12.236+
12.237+(defclass join-docs ()
12.238+ ((docs :initarg :docs
12.239+ :accessor :docs)))
12.240+
12.241+(defclass join-result ()
12.242+ ((docs :initarg :docs
12.243+ :accessor :docs)))
12.244+
12.245+(defun sort-key (doc)
12.246+ (get-val doc 'key))
12.247+
12.248+;; TODO: How to update log if collection is sorted? Make a snapshot?
12.249+(defmethod sort-collection ((collection collection)
12.250+ &key return-sort
12.251+ (sort-value-func #'sort-key) (sort-test-func #'>))
12.252+ (setf (docs collection)
12.253+ (sort (docs collection)
12.254+ sort-test-func
12.255+ :key sort-value-func))
12.256+ (if return-sort
12.257+ (docs collection)
12.258+ t))
12.259+
12.260+(defmethod db::sort-collection-temporary ((collection collection)
12.261+ &key (sort-value-func #'sort-key) (sort-test-func #'>))
12.262+ (let ((sorted-array (copy-array (docs collection))))
12.263+ (setf sorted-array
12.264+ (sort sorted-array
12.265+ sort-test-func
12.266+ :key sort-value-func))
12.267+ sorted-array))
12.268+
12.269+(defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func #'>))
12.270+ :documentation "Sorts array/list of docs and returns the sorted array."
12.271+ (sort docs
12.272+ sort-test-func
12.273+ :key sort-value-func))
12.274+
12.275+;;Add method for validation when updating a collection.
12.276+
12.277+(defclass xdb-sequence ()
12.278+ ((key :initarg :key
12.279+ :accessor key)
12.280+ (value :initarg :value
12.281+ :accessor value)))
12.282+
12.283+(defmethod enable-sequences ((xdb xdb))
12.284+ (add-collection xdb "sequences"
12.285+ :collection-class 'collection
12.286+ :load-from-file-p t))
12.287+
12.288+(defmethod next-sequence ((xdb xdb) key)
12.289+ (let ((doc (get-doc (get-collection xdb "sequences") key)))
12.290+ (unless doc
12.291+ (setf doc (make-instance 'xdb-sequence :key key :value 0)))
12.292+ (incf (get-val doc 'value))
12.293+ (store-doc (get-collection xdb "sequences")
12.294+ doc)
12.295+ (get-val doc 'value)))
13.1--- a/examples/examples.asd Sun Apr 14 20:48:05 2024 -0400
13.2+++ b/examples/examples.asd Sun Jun 16 22:15:04 2024 -0400
13.3@@ -9,9 +9,14 @@
13.4 ;; (:file "fast")
13.5 (:file "filtered")))
13.6 (:file "vegadat")
13.7+ (:file "mbdump")
13.8 (:module "db"
13.9 :components ((:file "cl-simple-example-raw")
13.10 (:file "mini-redis")
13.11 (:file "tao")
13.12- (:file "mbdb")))))
13.13+ (:file "mbdb")))
13.14+ (:module "net"
13.15+ :components ((:file "yoctochat")))
13.16+ (:module "app"
13.17+ :components ((:file "mpk")))))
13.18
14.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2+++ b/examples/mbdump.lisp Sun Jun 16 22:15:04 2024 -0400
14.3@@ -0,0 +1,114 @@
14.4+;;; examples/mbdump.lisp --- Prepare a sampling of mbdump JSON data
14.5+
14.6+;; WIP
14.7+
14.8+;;; Commentary:
14.9+
14.10+;; - considering sampling 'releases.json' only. could be a really good
14.11+;; benchmark. For now we will sample all files. Soon, we may split
14.12+;; releases.json into separate files here which is rather trivial
14.13+;; anyway.
14.14+
14.15+;; - using uiop:read-file-line is NOT the right thing to do. This is
14.16+;; too bad because I implemented a specialized stream class and then
14.17+;; deleted it before committing.
14.18+
14.19+;; - there are two possible solutions I can think of:
14.20+
14.21+;; - single-pass :: for each file, read the first line and calculate
14.22+;; the minimal space needed to store a json object in a single
14.23+;; line. Instead of incrementing over every character to find the
14.24+;; next line, we move the position once by the minimum space, then
14.25+;; iterate over characters until we find a newline. We walk the
14.26+;; entire file and pick up the random indexes.
14.27+
14.28+;; - double-pass :: for each file, read each line character by
14.29+;; character, counting new lines. At each random index calculate
14.30+;; and collect the file position. Do a second pass which sets the
14.31+;; file position on each iteration before reading a line.
14.32+
14.33+;;; Code:
14.34+#-prelude (ql:quickload :prelude)
14.35+(defpackage :mbdump
14.36+ (:use :cl :std :log :sb-thread :sb-concurrency :dat/json :cli/clap :obj/time :sb-gray)
14.37+ (:export :main :*target*))
14.38+
14.39+(in-package :mbdump)
14.40+
14.41+;; Ultimately we dump the samples to this directory. It should be
14.42+;; roughly 1/10th the original size.
14.43+#| (in-readtable :shell)
14.44+du -sh data/mbdump # 242G
14.45+du -sh /tmp/mbdump # 24G
14.46+|#
14.47+(defvar *mbdump-directory* (pathname "/mnt/y/data/packy/data/mbdump-full/"))
14.48+
14.49+(defun init-mbdump-files (&optional (dir *mbdump-directory*))
14.50+ "Count the total number of lines in each file under DIR. Return a
14.51+hash-table containing filenames->line counts.
14.52+
14.53+This is single-threaded so it does take some time on the full mbdump
14.54+dataset. If you run this make sure to assign the resulting value to
14.55+*MBDUMP-FILES*, otherwise use the pre-compiled value."
14.56+ (let ((files (find-files dir))
14.57+ (table (make-hash-table :test 'equal)))
14.58+ (mapc (lambda (f)
14.59+ (setf (gethash (file-namestring f) table) (count-file-lines f)))
14.60+ files)
14.61+ table))
14.62+
14.63+(defvar *mbdump-files* (let ((pairs '(("area.json" . 119164)
14.64+ ("artist.json" . 2345810)
14.65+ ("event.json" . 78896)
14.66+ ("instrument.json" . 1046)
14.67+ ("label.json" . 271609)
14.68+ ("place.json" . 63772)
14.69+ ("recording.json" . 119575)
14.70+ ("release-group.json" . 3204634)
14.71+ ("release.json" . 4111554)
14.72+ ("series.json" . 23376)
14.73+ ("work.json" . 2078152)))
14.74+ (table (make-hash-table :test 'equal)))
14.75+ (dolist (pair pairs table)
14.76+ (setf (gethash (car pair) table) (cdr pair)))))
14.77+
14.78+(defvar *target-directory* (pathname (concatenate 'string "/tmp/mbdump-" (file-date) "/")))
14.79+
14.80+(defvar *target* nil)
14.81+
14.82+(defun random-line-indexes (max &optional (count 1000))
14.83+ (declare (fixnum max count))
14.84+ (let ((ret))
14.85+ (labels ((%gen () (let ((int (random max)))
14.86+ (when (zerop int) (setf int 1))
14.87+ (if (find int ret)
14.88+ (%gen)
14.89+ int))))
14.90+ (sort
14.91+ (dotimes (i count ret)
14.92+ (setf ret (cons (%gen) ret)))
14.93+ #'<))))
14.94+
14.95+(defun prep-json-file (file)
14.96+ (let* ((in-path (merge-pathnames file *mbdump-directory*))
14.97+ (out-path (merge-pathnames file *target-directory*))
14.98+ (max (gethash (namestring file) *mbdump-files*))
14.99+ (count (floor max 10))
14.100+ (lines (random-line-indexes (gethash (namestring file) *mbdump-files*)))
14.101+ (res (cons out-path count)))
14.102+ (with-open-files ((out out-path :direction :output :external-format '(:utf-8 :replacement "?"))
14.103+ (in in-path :direction :input :external-format '(:utf-8 :replacement "?")))
14.104+ (loop for i in lines
14.105+ with line = (uiop:read-file-line in :at i)
14.106+ do (print (file-position in))
14.107+ do (write-line line out)))
14.108+ (push res *target*)))
14.109+
14.110+(defmain (:return *target*)
14.111+ (ensure-directories-exist *target-directory*)
14.112+ (let ((workers))
14.113+ (dolist (file (hash-table-keys *mbdump-files*) workers)
14.114+ (push (make-thread (lambda () (prep-json-file file)) :name (format nil "~A prep" file)) workers))
14.115+ (time (wait-for-threads workers))))
14.116+
14.117+;; (prep-json-file "label.json")
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/examples/net/yoctochat.lisp Sun Jun 16 22:15:04 2024 -0400
15.3@@ -0,0 +1,60 @@
15.4+;;; examples/net/yoctochat.lisp --- Yoctochat Implementation
15.5+
15.6+;; The tiniest (lisp) chat server on earth!
15.7+
15.8+;; based on https://github.com/robn/yoctochat
15.9+
15.10+;; A 'yoctochat' server will:
15.11+
15.12+;; - take a single commandline argument, the port to listen on
15.13+;; - open a listening port
15.14+;; - handle multiple connections and disconnections on that port
15.15+;; - receive text on a connection, and forward it on to all ofhter connections
15.16+;; - produce simple output about what it's doing
15.17+;; - demonstrate a single IO multiplexing technique as simply as possible
15.18+;; - be well commented!
15.19+
15.20+;;; Commentary:
15.21+
15.22+;; This implementation is based on the yc_uring.c implementation which
15.23+;; uses io_uring. To use io_uring from Lisp, we use the high-level IO
15.24+;; package, which internally calls foreign functions defined in the
15.25+;; URING package.
15.26+
15.27+;;
15.28+
15.29+;;; Code:
15.30+(defpackage :examples/yoctochat
15.31+ (:use :cl :std :net :cli/clap :io :log :sb-alien)
15.32+ (:import-from :uring :load-uring))
15.33+
15.34+(in-package :examples/yoctochat)
15.35+
15.36+;; To start using the IO package we should make sure the liburing
15.37+;; shared library is properly loaded. This function takes care of that
15.38+;; and arranges for the library to be remembered when entering a saved
15.39+;; lisp image such that it will be automatically re-opened.
15.40+(load-uring t)
15.41+
15.42+;; Initialize a simple logger to report on what's happening.
15.43+;; (setq *logger* (make-logger nil))
15.44+
15.45+;; Define some parameters for the queue depth and maximum number of
15.46+;; connections allowed on a single server.
15.47+(defparameter *num-conns* 128)
15.48+
15.49+(defparameter *queue-depth* (* 2 *num-conns*))
15.50+
15.51+(defclass yc-server (server)
15.52+ ((connections :initform nil ::type sequence))
15.53+ (:documentation "The Yoctochat Server. "))
15.54+
15.55+;; The main loop of our yoctochat server. The 'defmain' macro will
15.56+;; produce a function 'main' which can be saved as an executable
15.57+;; entry-point.
15.58+(defmain ()
15.59+ (init-io *queue-depth*)
15.60+ (setf *io* nil))
15.61+
15.62+
15.63+
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/examples/org/publish.lisp Sun Jun 16 22:15:04 2024 -0400
16.3@@ -0,0 +1,8 @@
16.4+;;; examples/org/publish.lisp --- Organ Publish Mockup
16.5+
16.6+;;
16.7+
16.8+;;; Code:
16.9+(defpackage :publish (:use :cl :std :dat :organ :doc))
16.10+(in-package :publish)
16.11+(doc:*source-file-types*
17.1--- a/makefile Sun Apr 14 20:48:05 2024 -0400
17.2+++ b/makefile Sun Jun 16 22:15:04 2024 -0400
17.3@@ -11,7 +11,7 @@
17.4 RS:Cargo.toml rustfmt.toml src/crates/*
17.5 CL:*/*.asd */*.lisp
17.6 deps:;
17.7-clean:;rm -rf */*.fasl;cargo clean
17.8+clean:;rm -rf **/*.fasl;cargo clean
17.9 fmt:$(RS);cargo fmt
17.10 build:$(RS) $(CL);cargo build --$(MODE);$(L_D)
17.11 --eval '(asdf:make "demo")' \
18.1--- a/readme.org Sun Apr 14 20:48:05 2024 -0400
18.2+++ b/readme.org Sun Jun 16 22:15:04 2024 -0400
18.3@@ -1,90 +1,4 @@
18.4 #+TITTLE: Demo
18.5-Welcome to our first demo system. What you will find here is a modular
18.6-client-server software stack which can be extended and customized by
18.7-the user at runtime.
18.8-
18.9-* How it works
18.10-The backend services are written in Rust and controlled by a simple
18.11-messaging protocol. Services provide common runtime capabilities known
18.12-as the /service protocol/ but are specialized on a unique /service
18.13-type/ which may in turn register their own /custom protocols/ (via
18.14-core).
18.15-
18.16-Services are capable of dispatching data directly to clients, or
18.17-storing data in the /database/ (sqlite, postgres, mysql).
18.18-
18.19-The frontend clients are pre-dominantly written in Common Lisp and
18.20-come in many shapes and sizes. There is a cli-client, web-client
18.21-(CLOG), docker-client (archlinux, stumpwm, McCLIM), and native-client
18.22-which also compiles to WASM (slint-rs).
18.23-
18.24-* Guide
18.25-** Build
18.26-- *install dependencies*
18.27- #+begin_src bash
18.28- ./tools/deps.sh
18.29- #+end_src
18.30-- *make executables* \\
18.31- Simply run =make build=. Read the ~makefile~ and change the options
18.32- as needed.
18.33-- MODE :: Mode (debug, release)
18.34-- LISP :: Lisp (sbcl, cmucl, ccl)
18.35-- CFG :: Config (default.cfg)
18.36-** Run
18.37-#+begin_src shell
18.38- ./demo -i
18.39-#+end_src
18.40-** Config
18.41-Configs can be specified in JSON, TOML, RON, or of course SEXP. See
18.42-=default.cfg= for an example.
18.43-** Play
18.44-The high-level user interface is presented as a multi-modal GUI
18.45-application which adapts to the specific application /instances/
18.46-below.
18.47-*** Weather
18.48-This backend retrieves weather data using the NWS API.
18.49-*** Stocks
18.50-The 'Stocks' backend features a stock ticker with real-time analysis
18.51-capabilities.
18.52-*** Bench
18.53-This is a benchmark backend for testing the capabilities of our
18.54-demo. It spins up some mock services and allows fine-grained control
18.55-of input/throughput.
18.56-* tasks
18.57-** TODO DSLs
18.58-- consider tree-sitter parsing layout, use as a guide for developing a
18.59- single syntax which expands to Rust or C.
18.60-- with-rs
18.61-- with-c
18.62-- with-rs/c
18.63-- with-cargo
18.64-- compile-rs/c
18.65-*** TODO rs-macroexpand
18.66-- rs-gen-file
18.67-- rs-defmacro
18.68-- rs-macros
18.69-- rs-macroexpand
18.70-- rs-macroexpand-1
18.71-*** TODO c-macroexpand
18.72-- c-gen-file h/c
18.73-- c-defmacro
18.74-- c-macros
18.75-- c-macroexpand
18.76-- c-macroexpand-1
18.77-*** TODO slint-macroexpand
18.78-- slint-gen-file
18.79-- slint-defmacro
18.80-- slint-macros
18.81-- slint-macroexpand
18.82-- slint-macroexpand-1
18.83-*** TODO html (using who)
18.84-** TODO web templates
18.85-create a basic static page in CL which will be used to host Slint UIs
18.86-and other WASM doo-dads in a browser.
18.87-** TODO CLI
18.88-using clingon, decide on generic options and write it up
18.89-** TODO docs
18.90-work on doc generation -- Rust and CL should be accounted for.
18.91-** TODO tests
18.92-We have none! need to make it more comfy - set up testing in all Rust
18.93-crates and for the lisp systems.
18.94+Welcome to the Compiler Company Demo. What you will find here is a
18.95+modular client-server software stack which can be extended and
18.96+customized by the user at runtime.
19.1--- a/skelfile Sun Apr 14 20:48:05 2024 -0400
19.2+++ b/skelfile Sun Jun 16 22:15:04 2024 -0400
19.3@@ -0,0 +1,7 @@
19.4+;;; demo/skelfile --- Demo Skeleton
19.5+:name demo
19.6+:author "Richard Westhaver <richard.westhaver@gmail.com>"
19.7+:version "0.1.0"
19.8+:description "The CC Demo System"
19.9+:rules
19.10+()
19.11\ No newline at end of file
20.1--- a/system-index.txt Sun Apr 14 20:48:05 2024 -0400
20.2+++ b/system-index.txt Sun Jun 16 22:15:04 2024 -0400
20.3@@ -1,2 +1,3 @@
20.4 demo.asd
20.5 examples/examples.asd
20.6+examples/db/xdb/xdb.asd
