changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/rdb/obj.lisp

changeset 110: cae8da4b1415
parent: db52ddb25d7f
child: 2aec94d6a480
author: ellis <ellis@rwest.io>
date: Mon, 18 Dec 2023 22:04:37 -0500
permissions: -rw-r--r--
description: rocksdb macrofication, fixes for RDB (C Strings will be the death of me), removed PWN - quicklisp package conflict, smh. 
     1 (in-package :rdb)
     2 
     3 ;;; rdb-opts
     4 (defvar *rdb-opts-lookup-table*
     5   (let ((table (make-hash-table :test #'equal)))
     6     (mapc (lambda (x) (setf (gethash (car x) table) (cdr x)))
     7           (loop for y across *rocksdb-options*
     8                 collect (cons y (format nil "rocksdb-options-set-~x" y))))
     9     table))
    10 
    11 (defmacro rdb-opt-setter (key)
    12   `(symbolicate (format nil "rocksdb-options-set-~x" ,key)))
    13 
    14 (defun %set-rocksdb-option (opt key val)
    15   (funcall (rdb-opt-setter key) opt val))
    16 
    17 ;; (funcall (rdb-opt-setter "create-if-missing") (rocksdb-options-create) nil)
    18 
    19 (defclass rdb-opts ()
    20   ((table :initarg :table :type hash-table :accessor rdb-opts-table)
    21    (sap :initarg :sap :type (or null alien) :accessor rdb-opts-sap)))
    22 
    23 (defmethod initialize-instance :after ((self rdb-opts) &rest initargs &key &allow-other-keys)
    24   (with-slots (sap table) self
    25     (unless (getf initargs :table) (setf table (make-hash-table :test #'equal)))
    26     (unless (getf initargs :sap) (setf sap (rocksdb-options-create)))
    27     (loop for (k v) on initargs by #'cddr while v
    28           do (let ((k (typecase k
    29                         (string (string-downcase k))
    30                         (symbol (string-downcase (symbol-name k)))
    31                         (t (string-downcase (format nil "~s" k))))))
    32                (set-opt self k v)))
    33     self))
    34 
    35 (defun make-rdb-opts (&rest values)
    36   (apply #'make-instance 'rdb-opts values))
    37 
    38 (defmethod get-opt ((self rdb-opts) key)
    39   "Return the current value of KEY in SELF if found, else return nil."
    40   (gethash key (rdb-opts-table self)))
    41 
    42 (defmethod set-opt ((self rdb-opts) key val &key push)
    43   "Set the VAL of KEY in SELF with '(setf (gethash SELF KEY) VAL)'."
    44   (prog1
    45       (setf (gethash key (rdb-opts-table self)) val)
    46     (when push (push-sap self key))))
    47 
    48 (defmethod push-sap ((self rdb-opts) key)
    49   "Push KEY from slot :TABLE to the instance :SAP."
    50   (%set-rocksdb-option (rdb-opts-sap self) key (get-opt self key)))
    51   
    52 (defmethod push-sap* ((self rdb-opts))
    53   "Initialized the SAP slot with values from TABLE."
    54   (with-slots (table) self
    55     (loop for k across (hash-table-keys table)
    56           do (push-sap self k))))
    57 
    58 (declaim (inline default-rdb-opts))
    59 (defun default-rdb-opts () 
    60   (make-rdb-opts
    61     :create-if-missing t 
    62     :total-threads 4
    63     :max-open-files 10000))
    64 
    65 ;;; bytes
    66 (defclass rdb-bytes (sequence)
    67     ((buffer :initarg :buffer :type (array unsigned-byte) :accessor rdb-bytes-buffer))
    68   (:documentation "RDB unsigned-byte array. Implements the iterator protocol."))
    69 
    70 (defmethod sequence:length ((self rdb-bytes))
    71   (length (rdb-bytes-buffer self)))
    72 
    73 (defmethod sequence:elt ((self rdb-bytes) index)
    74   (elt (rdb-bytes-buffer self) index))
    75 
    76 (defmethod sequence:make-sequence-like ((self rdb-bytes) length &key initial-element initial-contents)
    77   (let ((res (make-instance 'rdb-bytes)))
    78     (cond 
    79       ((and initial-element initial-contents) (error "supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like))
    80       (initial-element (setf (rdb-bytes-buffer res) (make-array length :element-type (array-element-type self)
    81                                                                        :initial-element initial-element)))
    82       (initial-contents (setf (rdb-bytes-buffer res) (make-array length :element-type (array-element-type self)
    83                                                                        :initial-contents initial-contents)))
    84       (t (setf (rdb-bytes-buffer res) (make-array length :element-type (array-element-type self)))))))
    85 
    86 ;; (sequence:make-sequence-iterator (make-instance 'rdb-bytes :buffer (vector 1 2 3)))
    87 (defmethod sequence:make-sequence-iterator ((self rdb-bytes) &key from-end start end)
    88   (sequence:make-sequence-iterator (rdb-bytes-buffer self) :from-end from-end :start start :end end))
    89 
    90 ;; (defmethod sequence:subseq ((self rdb-bytes) start &optional end))
    91 ;; (defmethod sequence:concatenate ((self rdb-bytes) &rest sequences))
    92 
    93 (defclass rdb-val (rdb-bytes)
    94   ()
    95   (:documentation "RDB value protocol.
    96 
    97 Values must be able to be encoded to and from (array unsigned-byte)."))
    98 
    99 (defun make-rdb-val (val)
   100   "Convert VAL to an object of type RDB-VAL."
   101   (make-instance 'rdb-val :buffer val))
   102 
   103 (defclass rdb-key (rdb-bytes)
   104   ()
   105   (:documentation "RDB key protocol.
   106 
   107 Keys must be able to be encoded to and from (array unsigned-byte)."))
   108 
   109 (defun make-rdb-key (key)
   110   "Convert KEY to an object of type RDB-KEY."
   111   (make-instance 'rdb-key :buffer key))
   112 
   113 (defclass rdb-kv (rdb-bytes)
   114   ((key :initarg :key :type rdb-key)
   115    (val :initarg :val :type rdb-val)))
   116 
   117 (defun make-rdb-kv (key val)
   118   "Generate a new RDB-KV pair."
   119   (make-instance 'rdb-kv 
   120     :key (make-rdb-key key) 
   121     :val (make-rdb-val val)))
   122 
   123 ;;; rdb-cf
   124 (defstruct rdb-cf
   125   "RDB Column Family structure. Contains a name, a cons of (rdb-key-type
   126 . rdb-val-type), and a system-area-pointer to the underlying
   127 rocksdb_cf_t handle."
   128   (name "" :type string)
   129   (kv (make-instance 'rdb-kv) :type rdb-kv)
   130   (sap nil :type (or null alien)))
   131 
   132 ;; TODO: fix
   133 (defun create-cf (db cf)
   134   (setf (rdb-cf-sap cf)
   135         (with-errptr (err 'rocksdb-cf-error (list :db db :cf (rdb-cf-name cf)))
   136           (rocksdb-create-column-family db (rocksdb-options-create) (rdb-cf-name cf) err))))
   137 
   138 ;;; rdb
   139 (defstruct (rdb (:constructor %make-rdb (name &optional opts cfs db)))
   140   (name "" :type string)
   141   (opts (default-rdb-opts) :type rdb-opts)
   142   (cfs (make-array 0 :element-type 'rdb-cf :adjustable t :fill-pointer 0) :type (array rdb-cf))
   143   (db nil :type (or null alien)))
   144 
   145 (defun make-rdb (name &optional opts cfs)
   146   "Construct a new RDB instance from NAME and optional OPTS and DB-PTR."
   147   (let ((db (%make-rdb name 
   148                        (or opts (default-rdb-opts)) 
   149                        (or cfs (make-array 0 :element-type 'rdb-cf :adjustable t :fill-pointer 0)))))
   150     (open-db db)
   151     db))
   152 
   153 (defmethod push-cf ((cf rdb-cf) (db rdb))
   154   (vector-push cf (rdb-cfs db)))
   155 
   156 (defmethod open-db ((self rdb))
   157   (setf (rdb-db self)
   158         (open-db-raw (rdb-name self) (rdb-opts-sap (rdb-opts self)))))
   159 
   160 (defmethod close-db ((self rdb))  
   161   (close-db-raw (rdb-db self))
   162   (setf (rdb-db self) nil))
   163 
   164 (defmethod destroy-db ((self rdb))  
   165   (when (rdb-db self) (close-db self))
   166   (destroy-db-raw (rdb-name self)))
   167 
   168 (defmethod init-db ((self rdb))
   169   (loop for cf across (rdb-cfs self)
   170         do (create-cf (rdb-db self) cf)))
   171 
   172 (defmethod insert-key ((self rdb) key val &key cf)
   173   (if cf
   174     (put-cf-raw
   175      (rdb-db self)
   176      (rdb-cf-sap (find cf (rdb-cfs self) :key #'rdb-cf-name :test #'equal))
   177      key
   178      val)
   179     (put-kv-raw
   180      (rdb-db self)
   181      key 
   182      val)))