changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/bin/rdb.lisp

changeset 560: b9c64be96888
parent: ea4f008ad13f
child: 42bc1432f217
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 26 Jul 2024 23:12:33 -0400
permissions: -rw-r--r--
description: make cli/clap more dynamic 
     1 ;;; rdb.lisp --- RocksDB client
     2 
     3 ;;; Code:
     4 (uiop:define-package :bin/rdb
     5     (:use :cl :rdb :std :cli/clap :log)
     6   (:export :main))
     7 
     8 (in-package :bin/rdb)
     9 (rocksdb:load-rocksdb t)
    10 (defopt rdb-help (print-help $cli))
    11 (defopt rdb-version (print-version $cli))
    12 (defopt rdb-log-level (when $val (setq *log-level* :debug)))
    13 (defvar *rdb*)
    14 (defopt rdb-target-db (setq *rdb* (create-db (or $val "rdb") :open nil)))
    15 
    16 ;; (defopt rdb-config (init-rdb-user-config (parse-file-opt $val)))
    17 
    18 (defcmd rdb-new
    19   (set-opt *rdb* :error-if-exists t)
    20   (open-db *rdb*)
    21   (println (rdb-name *rdb*)))
    22 
    23 (defcmd rdb-show
    24   (let ((db-path (cli-opt-val (car (find-opts $cli "db")))))
    25     (if (and (null db-path) (zerop $argc))
    26         (mapc (lambda (x) (println (format nil "~a ~a" (car x) (cdr x))))
    27               (hash-table-alist (backfill-opts (default-rdb-opts) :full t)))
    28         (with-db (db (create-db db-path :open t))
    29           (println (hash-table-alist (backfill-opts db)))
    30           (with-iter (it (create-iter db))
    31             (iter-seek-to-first it)
    32             (loop while (iter-valid-p it)
    33                   do (progn
    34                        (format t "~A : ~A~%"
    35                                (sb-ext:octets-to-string (iter-key it) :external-format '(:ascii :replacement #\_))
    36                                (iter-val it))
    37                        (iter-next it))
    38                   finally (rocksdb::rocksdb-iter-destroy %it)))))))
    39 
    40 (defcmd rdb-set
    41   (if (> 2 $argc)
    42       (rdb-error "missing args: KEY VAL")
    43       (with-db (db *rdb*)
    44         (open-db db)
    45         (insert-key  db (pop $args) (pop $args)))))
    46 
    47 (defcmd rdb-get
    48   (if (> 1 $argc)
    49       (rdb-error "missing arg: KEY")
    50       (with-db (db *rdb*)
    51         (open-db db)
    52         (when-let ((val (get-key db (car $args))))
    53           (println val)))))
    54 
    55 (defcmd rdb-destroy
    56   (destroy-db *rdb*))
    57 
    58 (defcmd rdb-fuzz
    59   (with-db (db *rdb*)
    60     (open-db db)
    61     (let ((val (make-array 32 :element-type 'octet)))
    62       (dotimes (i (if (zerop $argc) 1000 (parse-integer (car $args))))
    63         (nreversef val)
    64         (let ((seed (random 32)))
    65           (dotimes (ii seed)
    66             (setf (aref val ii) (random 256))))
    67           (nreversef val)
    68           (put-key db
    69                    (sb-ext:string-to-octets (string (gensym "foo")))
    70                    val)))))
    71 
    72 (define-cli $cli
    73   :name "rdb"
    74   :version "0.1.0"
    75   :thunk rdb-show
    76   :description "A simple helper for RocksDB."
    77   :opts (make-opts
    78           (:name "level" :global t :description "set the log level" :thunk rdb-log-level)
    79           (:name "help" :global t :description "print help" :thunk rdb-help)
    80           (:name "version" :global t :description "print version" :thunk rdb-version)
    81           (:name "db" :global t :description "target db" :thunk rdb-target-db :kind dir))
    82   :cmds (make-cmds
    83           (:name new :thunk rdb-new)
    84           (:name show :thunk rdb-show)
    85           (:name set :thunk rdb-set)
    86           (:name get :thunk rdb-get)
    87           (:name fuzz :thunk rdb-fuzz)
    88           (:name destroy :thunk rdb-destroy)))
    89 
    90 (defmain ()
    91   (let ((*log-level* :info))
    92     (with-slots (opts cmds args) *cli*
    93       ;; FIXME 2024-05-07: needs to be triggered explicitly - need to support
    94       ;; running global opt thunks even when no arg present - macro key
    95       (if (active-cmds $cli)
    96           (prog2 (do-opt (car (find-opts $cli "db")))
    97               (do-cmd $cli)
    98             (close-db *rdb*))
    99           (print-help $cli)))))