Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
114 lines (103 sloc) 3.07 KB
;;; -*- Gerbil -*-
;;; (C) vyzo at hackzen.org
;;; kvstore daemon
(import :gerbil/gambit
:std/sugar
:std/getopt
:std/logger
:std/actor
:std/text/json
:std/text/zlib
:std/db/lmdb
:tutorial/kvstore/proto)
(export main)
(def (run rpcd env)
(def db (lmdb-open-db env "kvstore"))
(def nil '#(nil))
(def (get key)
(let (txn (lmdb-txn-begin env))
(try
(let* ((bytes (lmdb-get txn db key))
(val (if bytes
(call-with-input-u8vector (uncompress bytes) read-json)
nil)))
(lmdb-txn-commit txn)
val)
(catch (e)
(lmdb-txn-abort txn)
(raise e)))))
(def (put! key val)
(let* ((bytes (call-with-output-u8vector [] (cut write-json val <>)))
(bytes (compress bytes))
(txn (lmdb-txn-begin env)))
(try
(lmdb-put txn db key bytes)
(lmdb-txn-commit txn)
(catch (e)
(lmdb-txn-abort txn)
(raise e)))))
(def (remove! key)
(let (txn (lmdb-txn-begin env))
(try
(lmdb-del txn db key)
(lmdb-txn-commit txn)
(catch (e)
(lmdb-txn-abort txn)
(raise e)))))
(rpc-register rpcd 'kvstore)
(while #t
(<- ((!kvstore.get key k)
(try
(let* ((val (get key))
(val
(if (eq? val nil)
#f
val)))
(!!value val k))
(catch (e)
(log-error "kvstore.get" e)
(!!error (error-message e) k))))
((!kvstore.ref key k)
(try
(let (val (get key))
(if (eq? val nil)
(!!error "No object associated with key" k)
(!!value val k)))
(catch (e)
(log-error "kvstore.ref" e)
(!!error (error-message e) k))))
((!kvstore.put! key val k)
(try
(put! key val)
(!!value (void) k)
(catch (e)
(log-error "kvstore.put!" e)
(!!error (error-message e) k))))
((!kvstore.remove! key k)
(try
(remove! key)
(!!value (void) k)
(catch (e)
(log-error "kvstore.remove!" e)
(!!error (error-message e) k))))
(what
(warning "Unexpected message: ~a " what)))))
(def (main . args)
(def gopt
(getopt (option 'listen "-l" "--listen"
default: "127.0.0.1:9999"
help: "rpcd listen address")
(argument 'path help: "lmdb path")))
(try
(let (opt (getopt-parse gopt args))
(start-logger!)
(let* ((rpcd (start-rpc-server! (hash-get opt 'listen)
proto: (rpc-cookie-proto)))
(env (lmdb-open (hash-get opt 'path))))
(spawn run rpcd env)
(thread-join! rpcd)))
(catch (getopt-error? exn)
(getopt-display-help exn "kvstored" (current-error-port))
(exit 1))
(catch (uncaught-exception? exn)
(display-exception (uncaught-exception-reason exn) (current-error-port)))))