Coverage report: /home/ellis/comp/core/lib/obj/db.lisp

Kind	Covered	All	%
expression	97	474	20.5
branch	12	60	20.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/obj/db/proto.lisp --- Database Protocol

2

3

;;

4

5

;;; Commentary:

6

7

;; This set of

8

9

;;; Code:

10

(in-package :obj/db)

11

12

;;; Vars

13

(defvar *db* nil)

14

(defvar *database-backend* nil)

15

(defvar *database-collection-type* 'list)

16

(defvar *default-database-version* '(0 1 0))

17

(defvar *default-kv-size* 8)

18

(defparameter *save-database-backend-on-load* nil)

19

;;; Backends

20

(defvar *database-backends* (make-hash-table)

21

"Hash Table where keys are a database backend designator and values

22

are a list of functions which are responsible for doing all initialization

23

such as loading shared libraries and setting variables.")

24

25

(defvar *database-backend-options* (make-hash-table)

26

"Hash Table where keys are a database backend designator and values are a

27

lambda-list which will be interpreted by PARSE-DATABASE-BACKEND-OPTIONS within

28

the body of WITH-DB forms.")

29

30

(defvar *database-backend-close-options* '(close destroy))

31

32

(defun add-database-loader (backend thunk)

33

(let ((flist (gethash backend *database-backends*)))

34

(setf (gethash backend *database-backends*) (pushnew thunk flist :test 'equalp))))

35

36

(defun add-database-backend-option (backend option)

37

"Add a new database backend option."

38

(let ((olist (gethash backend *database-backend-options*)))

39

(setf (gethash backend *database-backend-options*) (pushnew option olist))))

40

41

(defun set-database-backend (backend options &rest thunks)

42

"Set the loaders (a sequence of thunks) and options for the designated database

43

backend keyword BACKEND."

44

(setf (gethash backend *database-backends*) thunks

45

(gethash backend *database-backend-options*) options))

46

47

(declaim (inline %load-database-backend))

48

(defun %load-database-backend (backend)

49

(when-let ((be (gethash backend *database-backends*)))

50

(dolist (th be)

51

(funcall th))))

52

53

(defun load-database-backend (backend &optional save)

54

"Load database BACKEND and set value of *DATABASE-BACKEND*. When SAVE is

55

non-nil also arrange for the BACKEND to be loaded on init when this core is

56

saved."

57

(let ((*save-database-backend-on-load* save))

58

(%load-database-backend backend)

59

(setq *database-backend* backend)))

60

61

(defun %database-backend-option-key (item)

62

(keywordicate (if (atom item) item (car item))))

63

64

;; TODO 2024-11-10: should we handle &rest/&optional too?

65

(defun parse-database-backend-options (initargs)

66

"Parse INITARGS as a plist of database options for current *DATABASE-BACKEND*."

67

(mapcar ;; for each registered database backend option..

68

(lambda (opt)

69

(let ((key (%database-backend-option-key opt)))

70

(if (member key initargs)

71

(let ((match (getf initargs key)))

72

(if (atom opt) (cons opt match) (cons (car opt) match)))

73

opt)))

74

(gethash *database-backend* *database-backend-options*)))

75

76

(defgeneric set-database-backend-option (db key val)

77

(:method (db (key (eql :open)) val)

78

(when val

79

(open-db db)))

80

(:method (db (key (eql :close)) val)

81

(when val

82

(close-db db)))

83

(:method (db (key (eql :destroy)) val)

84

(when val

85

(close-db db)

86

(destroy-db db)))

87

(:method (db (key (eql :path)) val)

88

(setf (path db) val))

89

(:method (db (key (eql :name)) val)

90

(setf (name db) val))

91

(:method (db (key (eql :id)) val)

92

(setf (id db) val))

93

(:method (db (key (eql :sap)) val)

94

(setf (sap db) val))

95

(:method (db (key (eql :opts)) val)

96

(setf (db-opts db) val))

97

(:method (db (key (eql :opt)) (val cons))

98

(set-db-opt db (car val) (cdr val)))

99

(:method (db (key (eql :shutdown)) val)

100

(shutdown-db db :wait (eql val :wait))))

101

102

(defun set-database-backend-options (db &rest options)

103

(mapc (lambda (opt)

104

(set-database-backend-option

105

db

106

(keywordicate (car opt))

107

;; WARNING eval here

108

(eval (cdr opt))))

109

options))

110

111

(defun do-database-backend-init-options (db &rest options)

112

(apply 'set-database-backend-options

113

db

114

(remove-if

115

(lambda (x)

116

(or (atom x)

117

(null (cdr x))

118

(member (car x) *database-backend-close-options*)))

119

options)))

120

121

(defun do-database-backend-close-options (db &rest options)

122

(apply 'set-database-backend-options

123

db

124

(remove-if

125

(lambda (x)

126

(or (atom x)

127

(null (cdr x))

128

(not (member (car x) *database-backend-close-options*))))

129

options)))

130

131

(defmacro with-db ((var &rest initargs &key (db '*db*) &allow-other-keys)

132

&body body)

133

"Bind VAR to a DATABASE instance produced by parsing INITARGS for the extent

134

of BODY."

135

(with-gensyms (opts)

136

`(let ((,opts ',(parse-database-backend-options initargs))

137

(,var ,db))

138

;; ,@(when open (remf initargs :open) `((open-db ,var)))

139

(apply 'do-database-backend-init-options ,var ,opts)

140

(unwind-protect (progn ,@body)

141

;; ,@(when close (remf initargs :close) `((close-db ,var)))

142

;; ,@(when destroy (remf initargs :destroy) `((destroy-db ,var)))

143

(apply 'do-database-backend-close-options ,var ,opts)))))

144

145

;;; Config

146

(defconfig db-config ()

147

((backend :initform :rdb :type database-backend-designator)

148

(options)))

149

150

;;; Conditions

151

(define-condition db-condition () ()

152

(:documentation "Superclass for DB conditions."))

153

154

(deferror not-a-database (db-condition invalid-argument) ()

155

(:documentation "Error signaled when an illegal DB is detected.")

156

(:default-initargs

157

:reason "Object is not a database")

158

(:auto t))

159

160

;;; Database

161

(defgeneric db (self)

162

(:documentation "Return the Database associated with SELF."))

163

164

(defgeneric db-lock (self)

165

(:documentation "Return an optional database MUTEX."))

166

167

(defgeneric database-version (self)

168

(:documentation "Return the version associated with a given database SELF."))

169

170

(defmethod database-version :around (self)

171

(declare (ignorable self))

172

(let ((version (call-next-method)))

173

(std/macs:ifret version

174

*default-database-version*)))

175

176

(defun prior-version-p (v1 v2)

177

"Is v1 an equal or earlier version than v2"

178

(cond ((and (null v1) (null v2)) t)

179

((and (null v1) (not (null v2))) t)

180

((and (not (null v1)) (null v2)) nil)

181

((< (car v1) (car v2)) t)

182

((> (car v1) (car v2)) nil)

183

((= (car v1) (car v2))

184

(prior-version-p (cdr v1) (cdr v2)))

185

(t (error "Version comparison problem: (prior-version-p ~A ~A)" v1 v2))))

186

187

(defclass database ()

188

((db :initform nil :initarg :db :accessor db))

189

(:documentation "Base class for Database objects."))

190

191

(defclass database-collection () ()

192

(:documentation "A collection of DATABASE objects."))

193

194

(defgeneric make-db (engine &rest initargs &key &allow-other-keys)

195

(:documentation "Dispatch initializer for databases. An ENGINE must be supplied, which is

196

usually a key such as :ROCKSDB or :SQLITE."))

197

198

(defgeneric connect-db (db &key &allow-other-keys)

199

(:documentation "Connect the database DB."))

200

201

(defgeneric query-db (db query &key &allow-other-keys)

202

(:documentation "Execute QUERY against DB."))

203

204

(defgeneric db-get (db key &key &allow-other-keys)

205

(:documentation "Return the value associated with KEY from DB."))

206

207

(defgeneric (setf db-get) (db key val &key &allow-other-keys))

208

209

(defgeneric db-set (db key val &key &allow-other-keys)

210

(:documentation "Set the value associated with KEY from DB to VAL.")

211

(:method (db key val &rest args)

212

(setf (apply #'db-get db key args) val)))

213

214

(defgeneric close-db (db &key &allow-other-keys)

215

(:documentation "Close a database."))

216

217

(defgeneric open-db (self)

218

(:documentation "Open a database."))

219

220

(defgeneric destroy-db (self)

221

(:documentation "Destroy all traces of a database, deleting any on-disk data and shutting down

222

in-memory objects."))

223

224

(defgeneric find-db (name dbs &key &allow-other-keys)

225

(:documentation "Return the db by NAME, from a collection of databases DBS."))

226

227

(defgeneric insert-db (name dbs &key &allow-other-keys)

228

(:documentation "Inserts a database by NAME into the database-collection DBS."))

229

230

(defgeneric db-open-p (self)

231

(:documentation "Return T when database SELF is open.")

232

(:method ((self t)) (not-a-database self))

233

(:method ((self database)) (when (db self) t)))

234

235

(defgeneric db-closed-p (self)

236

(:documentation "Return T when database SELF is closed.")

237

(:method ((self t)) (not-a-database self))

238

(:method ((self database)) (unless (db self) t)))

239

240

;;; Common

241

(defun slot-val (instance slot-name)

242

(if (and instance

243

(slot-boundp instance slot-name))

244

(slot-value instance slot-name)))

245

246

(defgeneric get-val (object element &key &allow-other-keys)

247

(:documentation "Returns the value in a object based on the supplied element name and possible

248

type hints.")

249

(:method (object element &key data-type)

250

(when object

251

(typecase object

252

(hash-table

253

(gethash element object))

254

(standard-object

255

(slot-val object element))

256

(t

257

(if data-type

258

(cond

259

((equal 'alist data-type)

260

(second (assoc element object :test #'equal)))

261

((equal 'plist data-type)

262

(get object element))

263

(t

264

                 (error "Does not handle this type of object. Implement your own get-val method.")))

265

(if (listp object)

266

(second (assoc element object :test #'equal))

267

                  (error "Does not handle this type of object. Implement your own get-val method."))))))))

268

269

(defgeneric (setf get-val) (new-value object element &key &allow-other-keys)

270

(:documentation "Set the value in a object based on the supplied element name and possible type

271

hints.")

272

(:method (new-value object element &key data-type)

273

(typecase (or data-type object)

274

(hash-table (setf (gethash element object) new-value))

275

(standard-object (setf (slot-value object element) new-value))

276

(t

277

(if data-type

278

(cond ((equal 'alist data-type)

279

(replace object (list (list element new-value))))

280

((equal 'plist data-type)

281

;;TODO: Implement this properly.

282

(get object element ))

283

(t

284

                   (error "Does not handle this type of object. Implement your own get-val method.")))

285

(if (listp object)

286

(replace object (list (list element new-value)))

287

                (error "Does not handle this type of object. Implement your own get-val method.")))))))

288

289

(defgeneric get-value (elt obj)

290

(:method (elt (obj sequence))

291

(find elt obj :test 'equal))

292

(:method (elt (obj hash-table))

293

(gethash elt obj)))

294

295

(defgeneric (setf get-value) (new elt obj))

296

297

(defgeneric put-kv (self kv)

298

(:documentation "Insert a KeyVal object."))

299

(defgeneric put-key (self key val)

300

(:documentation "Insert a KEY and VAL."))

301

(defgeneric put-key-ts (self key val ts)

302

(:documentation "Insert a KEY and VAL with associated timestamp TS."))

303

(defgeneric get-key (self key &key)

304

(:documentation "Get value of KEY."))

305

(defgeneric multi-get (self keys &key)

306

(:documentation "Retrieve multiple KEYS from SELF."))

307

308

(defgeneric insert-key (self key val &key)

309

(:documentation "Insert KEY:VAL into SELF."))

310

(defgeneric insert-kv (self kv &key)

311

(:documentation "Insert KV object into SELF."))

312

(defgeneric delete-key (self key &key)

313

(:documentation "Delete value associated with KEY from SELF."))

314

(defmethod remove-kv (key value self))

315

(defgeneric delete-key-ts (self key ts)

316

(:documentation "Delete value associated with KEY and TS from SELF."))

317

(defgeneric delete-key-range (self start end &key)

318

(:documentation "Delete values associates with keys between START and END from SELF."))

319

(defgeneric flush-db (self &key)

320

(:documentation "Flush the database SELF."))

321

(defgeneric sync-db (self other &key) ;;nyi

322

(:documentation "Perform a synchronization on SELF using OTHER."))

323

(defgeneric load-db (self)

324

(:documentation "Load an existing database."))

325

(defgeneric db-stats (self &optional type)

326

(:documentation "Return TYPE stats of given database."))

327

(defgeneric db-metadata (self &optional type)

328

(:documentation "Return TYPE metdata of given database."))

329

(defgeneric db-prop (self type)

330

(:documentation "Return TYPE property of given database."))

331

(defgeneric db-opt (self key)

332

(:documentation "Return value of database option KEY."))

333

(defgeneric db-opts (self)

334

(:documentation "Accessor for database options of SELF."))

335

(defgeneric (setf db-opts) (new self)

336

(:documentation "Return value of database option KEY."))

337

(defgeneric (setf db-opt) (new self key &key &allow-other-keys)

338

(:documentation "Set the value of database option KEY."))

339

(defgeneric set-db-opt (self key val &key &allow-other-keys)

340

(:documentation "Convenience setter for DB-OPT.")

341

(:method ((self t) key val &key)

342

(setf (db-opt self key) val))

343

(:method ((self t) key val &key push)

344

(setf (db-opt self key :push push) val)))

345

(defgeneric repair-db (self &key)

346

(:documentation "Attempt to repair the database SELF."))

347

(defgeneric backup-db (self &key)

348

(:documentation "Create a new backup for database SELF."))

349

(defgeneric db-backup (self)

350

(:documentation "Access the current backup of database SELF."))

351

(defgeneric secondary-db (self)

352

(:documentation "Accessor for the secondary-db of a database SELF."))

353

(defgeneric restore-db (self from &key)

354

(:documentation "Restore database SELF from object FROM."))

355

(defgeneric snapshot-db (self)

356

(:documentation "Create a new snapshot for database SELF."))

357

(defgeneric write-batch (self batch &key)

358

(:documentation "Write BATCH to database SELF."))

359

(defgeneric shutdown-db (self &key wait &allow-other-keys)

360

(:documentation "Shutdown database SELF."))

361

(defgeneric ingest-into-db (self file &key)

362

(:documentation "Ingest an external file into the database"))

363

364

;; Merge Ops

365

(defgeneric merge-key (self key val &key)

366

(:documentation "Perform a merge operation on SELF using KEY and VAL."))

367

(defgeneric merge-kv (self kv &key)

368

(:documentation "Perform a merge operation on SELF using object KV."))

369

370

(defmacro with-merge-op ())

371

372

;; Columns

373

(defgeneric open-column (self col &key)

374

(:documentation "Open and return a column from SELF."))

375

(defgeneric open-columns (self &rest columns)

376

(:documentation "Open the columns or all columns belonging to SELF."))

377

(defgeneric open-columns* (self)

378

(:documentation "Open all columns belonging to SELF."))

379

(defgeneric open-with-columns (self &rest names)

380

(:documentation "Open a database with columns indicated by NAMES or all columns belonging to

381

SELF. This function may error when (DB-OPEN-P SELF) is non-nil."))

382

(defgeneric close-column (self &optional error)

383

(:documentation "Close the column SELF. When ERROR is non-nil signal an error if the

384

column is already closed."))

385

(defgeneric close-columns (self)

386

(:documentation "Close the columns belonging to SELF."))

387

(defgeneric destroy-column (self &optional error)

388

(:documentation "Close the column SELF. When ERROR is non-nil signal an error if the

389

column is already closed."))

390

(defgeneric destroy-columns (self)

391

(:documentation "Close the columns belonging to SELF."))

392

(defgeneric create-column (self cf)

393

(:documentation "Create the column belonging to SELF."))

394

(defgeneric create-columns (self)

395

(:documentation "Create the columns belonging to SELF."))

396

(defgeneric find-column (col self &key)

397

(:documentation "Find the column COL in SELF."))

398

(defgeneric (setf find-column) (new col self &key)

399

(:documentation "Find the column COL in SELF."))

400

(defgeneric flush-column (self col &key)

401

(:documentation "Flush the column COL in SELF."))

402

(defgeneric add-column (col self)

403

(:documentation "Add a column to SELF."))

404

(defgeneric column-opts (col))

405

(defgeneric (setf column-opts) (new col))

406

407

;;; KV

408

(defstruct (kv (:constructor make-kv (&optional key val)))

409

(key (make-octets *default-kv-size*) :type octet-vector)

410

(val (make-octets *default-kv-size*) :type octet-vector))

411

412

(defgeneric make-val (val)

413

(:documentation "Coerce VAL into an OCTET-VECTOR.")

414

(:method ((val null))

415

#())

416

(:method ((val string))

417

(sb-ext:string-to-octets val))

418

(:method ((val vector))

419

(if (octet-vector-p val)

420

val

421

(call-next-method)))

422

(:method ((val t))

423

(coerce val 'octet-vector)))

424

425

(defgeneric make-key (key)

426

(:documentation "Coerce KEY into an OCTET-VECTOR.")

427

(:method ((val null))

428

#())

429

(:method ((val string))

430

(sb-ext:string-to-octets val))

431

(:method ((val integer))

432

(integer-to-octets val))

433

(:method ((val vector))

434

(if (octet-vector-p val)

435

val

436

(call-next-method)))

437

(:method ((val t))

438

(coerce val 'octet-vector)))

439

440

;;; Transactions

441

442

;; In our system, transactions must be one of the following:

443

444

;; - A non-nil list

445

;; - A subclass of TRANSACTION-OBJECT

446

;; - Implement a TRANSACTION-DB method which returns an instance of DATABASE

447

448

;; Simple transactions are non-nil lists which are handled according to the

449

;; current database backend.

450

451

#| notes

452

453

- *TXN* is bound to the current transaction being executed. A value of NIL

454

represents no transaction. The current *DATABASE-BACKEND* may modify this

455

variable within the EXECUTE-TRANSACTION method.

456

- should never be bound within the body of a transaction

457

458

- The macros WITH-TRANSACTION and ENSURE-TRANSACTION will always abort the

459

transaction in response to any non-local exit.

460

461

- WITH-TRANSACTION passes *TXN* to EXECUTE-TRANSACTION

462

463

|#

464

(deftype simple-transaction () `(and (not null) list))

465

466

(defvar *default-txn* '(nil nil nil))

467

(defvar *txn* nil

468

"The current transaction.")

469

470

(defclass transaction-object () ()

471

(:documentation "Base class for transaction objects."))

472

473

(defgeneric (setf transaction-opts) (new txn))

474

475

(defgeneric make-transaction (self &key &allow-other-keys)

476

(:documentation "Make a new transaction object.")

477

(:method ((self null) &key) *default-txn*))

478

479

(defgeneric prepare-transaction (self &key)

480

(:documentation "Prepare a transaction."))

481

482

(defgeneric rollback-transaction (self &key)

483

(:documentation "Rollback a transaction."))

484

485

(defgeneric commit-transaction (self &key)

486

(:documentation "Commit a transaction."))

487

488

(defgeneric execute-transaction (self kernel &rest args &key &allow-other-keys)

489

(:documentation

490

"Interface to the backend transaction kernel (a function). The body of the

491

kernel function should be executed in an environment that protects against

492

non-local exits, provides ACIDic properties and binds any relevant parameters."))

493

494

(defgeneric abort-transaction (self &key &allow-other-keys))

495

496

(defgeneric transaction-object-p (self)

497

(:documentation "Return Non-nil if SELF is a transaction object.")

498

(:method ((self t))

499

(or (typep 'simple-transaction self)

500

(subtypep (type-of (transaction-db self)) 'database)))

501

(:method ((self transaction-object)) t))

502

503

(defgeneric transaction-object (self)

504

(:documentation "Return the underlying object of a transaction.")

505

(:method ((self list)) (second self)))

506

(defgeneric transaction-store (self)

507

(:documentation "Return the underlying STORE of a transaction.")

508

(:method ((self list)) (first self)))

509

(defgeneric transaction-db (self)

510

(:documentation "Return the underlying TRANSACTION-DB of a transaction. This may or may not

511

return the same value as DB depending on backend.")

512

(:method ((self t)) *db*))

513

(defgeneric transaction-prior (self)

514

(:documentation "Return the previous transaction of SELF if any.")

515

(:method ((self list)) (third self)))

516

517

(defun known-transaction (db txn)

518

"Search for a prior TXN known by this DB."

519

(when txn

520

(or (and (transaction-object-p txn)

521

(or (eq db (transaction-db txn))

522

(eq db (transaction-store txn)))

523

txn

524

(known-transaction db (transaction-prior txn))))))

525

526

(define-condition transaction-retry-count-exceeded (error)

527

((count :initarg :count :accessor retry-count :initform 0)))

528

529

(defvar *default-txn-wait* 0.1)

530

(defvar *default-txn-retry* 0)

531

532

;; From ELEPHANT

533

(defmacro with-transaction ((&rest initargs

534

&key (db '*db*)

535

(store '*store*)

536

(txn '*txn*)

537

retries

538

wait

539

&allow-other-keys)

540

&body body)

541

"Execute a body with a transaction in place. On success, the transaction is

542

committed. Otherwise, the transaction is aborted."

543

(with-gensyms (%db %txn-fn)

544

(remf initargs :db)

545

(remf initargs :store)

546

(remf initargs :txn)

547

(remf initargs :retries)

548

(remf initargs :wait)

549

`(let* ((,%db (or ,db ,store))

550

(,%txn-fn (lambda () ,@body)))

551

(funcall #'execute-transaction ,%db ,%txn-fn

552

:txn (awhen (known-transaction ,%db ,txn) (transaction-object it))

553

,@(when retries `(:retries ,retries))

554

,@(when wait `(:wait ,wait))

555

,@initargs))))

556

557

(defmacro current-transaction (db)

558

"Return the current transaction associated with database DB."

559

(with-gensyms (txn)

560

`(let ((,txn *txn*))

561

(when (and ,txn (eq (transaction-db ,txn) ,db))

562

(transaction-object ,txn)))))

563

564

(defmacro ensure-transaction ((&rest initargs &key

565

(db '*db*)

566

(store '*store*)

567

(txn '*txn*)

568

retries wait

569

&allow-other-keys)

570

&body body)

571

"Execute BODY with an existing transaction or a new transaction if one does not

572

exist. This macro allows for the sequencing of database actions to be run

573

atomically regardless of whether there is an existing transaction or not."

574

(with-gensyms (%db %txn-fn)

575

(remf initargs :db)

576

(remf initargs :store)

577

(remf initargs :txn)

578

(remf initargs :retries)

579

(remf initargs :wait)

580

`(let ((,%db (or ,db ,store))

581

(,%txn-fn (lambda () ,@body)))

582

(if (known-transaction ,%db ,txn)

583

(funcall ,%txn-fn)

584

(funcall #'execute-transaction ,%db

585

,%txn-fn

586

:txn nil

587

,@(when retries `(:retries ,retries))

588

,@(when wait `(:wait ,wait)))))))

589

590

(defmacro with-batch-transaction ((batch size list &rest txn-options) &body body)

591

"Perform a set of DB operations over a sequence of elements LIST in batches of

592

SIZE. Transaction keywords accepted by WITH-TRANSACTION are accepted

593

immediately following LIST."

594

`(loop for ,batch in (group ,list ,size)

595

do (with-transaction ,txn-options

596

,@body)))