~amirouche/ruse-babeltoy

cdd7cf62cd4d20aa9cd40fc3b9215ceae3f82f51 — Amirouche 1 year, 22 days ago dcae609 fdb
wip
M babeltoy.scm => babeltoy.scm +2 -11
@@ 230,17 230,10 @@
               (string->bag-of-words string))))

(define (index! tx url sxml tokens)
  ;; TODO: Skip if URL contains a query string
  (define uid (random-uid))

  (define ignored (for-each (lambda (token) (index-document-frequency! tx token)) tokens))

  (define (add! token)
    (pk 'add! url token)
    (index-backward-add! tx token uid))
    (index-backward-add! tx token url))

  (pk 'foward url)
  (index-forward-set! tx uid url sxml)
  (index-forward-set! tx url sxml)

  (for-each add! tokens))



@@ 262,8 255,6 @@
        #f
        (let* ((sxml (html->sxml (cadr uri+body)))
               (tokens (string->tokens (sxml->human-readable-text sxml))))
          (pk (string-length (cadr uri+body)))
          (display ".")(flush-output-port)
          (fdb-in-transaction db
                              (lambda (tx)
                                (index! tx

M makefile => makefile +2 -26
@@ 1,38 1,15 @@
PREFIX=$(PWD)
FILENAME=babeltoy
.PHONY: help doc

help: ## This help.
	@awk 'BEGIN {FS = ":.*?## "} /^[a-zA-Z_-]+:.*?## / {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' $(MAKEFILE_LIST) | sort

build: okvslite ## Rebuild all the project and documentation
	ln -sf README.md $(FILENAME).md
	pandoc --from=gfm README.md -o $(FILENAME).html
	pandoc --standalone $(FILENAME).html -o $(FILENAME).pdf

todo: ## Things that should be done
	@grep -nR --color=always  --before-context=2  --after-context=2 TODO found/

xxx: ## Things that require attention
	@grep -nR --color=always --before-context=2  --after-context=2 XXX found/

check:
	# scheme --libdirs $(PWD)/src/ --program tests/htmlprag.test.scm
	# scheme --libdirs $(PWD)/src/ --program tests/bow.test.scm
	# scheme --libdirs $(PWD)/src/ --program tests/warc-reader.test.scm
	scheme --libdirs $(PWD)/src/ --program tests/wbow.test.scm

repl:
	scheme --libdirs $(PWD)/src

okvslite:
	which tclsh || echo "Install tclsh from tcl package"
	mkdir -p local/src
	mkdir -p local/lib
	rm -rf local/src/sqlite
	cd $(PREFIX)/local/src && git clone --depth=1 https://github.com/sqlite/sqlite/
	cp ./patches/MakefileLSM $(PREFIX)/local/src/sqlite
	cd $(PREFIX)/local/src/sqlite/ && make -f MakefileLSM lsm.so
	cd $(PREFIX)/local/src/sqlite/ && cp lsm.so ../../lib/
# The above can be shared among several projects

foundationdb: ## Install foundationdb
	mkdir -p local


@@ 44,4 21,3 @@ foundationdb: ## Install foundationdb

foundationdb-clear:  ## Remove all data from the database
	fdbcli --exec "writemode on; clearrange \x00 \xFF;"


M src/foundationdb.scm => src/foundationdb.scm +238 -180
@@ 1,55 1,74 @@
#!chezscheme
;; foundationdb

;; Copyright © 2019-2020 Amirouche BOUBEKKI <amirouche at hyper dev>

;;
;; Copyright © 2019-2021 Amirouche BOUBEKKI <amirouche at hyper dev>
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;
;;; Comment:
;;
;; - 2019/05: initial version
;;
;; - 2020/02: port to arew
;; - 2021/08: rework
;;
(library (foundationdb)

  (export
   fdb-error
   fdb-error-ref
   fdb-error-predicate
   fdb-select-api-version
   fdb-setup-network
   fdb-setup-network!
   fdb-run-network
   fdb-stop-network
   fdb-future-cancel
   fdb-future-cancel!
   fdb-future-release-memory
   fdb-future-destroy
   fdb-future-block-until-ready
   fdb-future-ready?
   fdb-future-callback
   fdb-future-set-callback
   fdb-future-set-callback!
   fdb-future-get-error
   fdb-future-get-int64
   fdb-future-get-key
   fdb-future-get-value
   fdb-future-get-range
   fdb-future-get-range-page
   fdb-create-database
   fdb-database-destroy
   fdb-database-create-transaction
   fdb-transaction-destroy
   fdb-transaction-cancel
   fdb-transaction-cancel!
   fdb-transaction-get
   fdb-transaction-get-range
   fdb-transaction-set
   fdb-transaction-atomic-op
   fdb-transaction-clear
   fdb-transaction-clear-range
   fdb-transaction-commit
   fdb-transaction-get-range-page
   fdb-transaction-set!
   fdb-transaction-atomic-op!
   fdb-transaction-clear!
   fdb-transaction-clear-range!
   fdb-transaction-commit!
   fdb-transaction-on-error
   )
   fdb-transaction-reset!)

  (import (chezscheme))
  (import (chezscheme) (foundationdb helpers))

  (begin

    (define (pk . args)
      (display args)(newline)
      (car (reverse args)))

    (define-syntax define-syntax-rule
      (syntax-rules ()
        ((define-syntax-rule (keyword args ...) body)


@@ 57,32 76,27 @@
           (syntax-rules ()
             ((keyword args ...) body))))))

    (define (bytevector->pointer bv)
    (define (bytevector-pointer bv)
      (#%$object-address bv (+ (foreign-sizeof 'void*) 1)))

    (define-syntax-rule (with-lock obj body ...)
      (begin (lock-object obj)
             (call-with-values (lambda () body ...)
               (lambda out
                 (unlock-object obj)
                 (apply values out)))))

    ;; ffi helpers

    (define (make-double-pointer)
      ;; Instead of foreign-alloc, let's use a bytevector to create
      ;; the double pointer from a Scheme object so that it is handled
      ;; by Chez garbage collector; That rely on #%$ private procedure
      ;; tho; also it is more dangerous, it might lead to memory
      ;; error; copy the pointed to data as soon as possible; or the
      ;; garbage collector will reap it. Dangerous life.
      (foreign-alloc 8))

    (define-syntax-rule (dereference  pointer)
    (define-syntax-rule (pointer-dereference pointer)
      (foreign-ref 'void* pointer 0))

    (define-syntax-rule (ftype->pointer ftype)
      (ftype-pointer-address ftype))

    (define-syntax-rule (pointer->ftype ftype pointer)
      (make-ftype-pointer ftype pointer))
    ;; the following sugar is pointless.

    (define-syntax-rule (foreign-procedure* return ptr args ...)
      (foreign-procedure  ptr (args ...) return))
      (foreign-procedure ptr (args ...) return))

    ;; foundationdb bindings



@@ 92,43 106,53 @@
    ;; foundationdb enums
    ;;

    ;; TODO
    ;; TODO: add foundationdb enums

    ;;
    ;; foundationdb bindings
    ;;

    (define fdb-error
    (define fdb-error-ref
      (let ((func (foreign-procedure* string "fdb_get_error" int)))
        (lambda (code)
          (func code))))

    (define-syntax-rule (check code)
      (let ((code* code))
        (unless (= code* 0)
          (raise (list 'foundationdb code* (fdb-error code*))))))
        (unless (fxzero? code*)
          ;; TODO: wrap with a Chez condition to ease debugging.
          (raise (list 'foundationdb code* (fdb-error-ref code*))))))

    ;; (define fdb-error-predicate
    ;;   (let ((func (foreign-procedure* int "fdb_error_predicate" ffi:int error)))
    ;;     (lambda (predicate-test code)
    ;;       (= 1 (func predicate-test code)))))
    (define (fdb-error code)
      (errorf 'foundationdb (fdb-error-ref code) code))
    
    (define fdb-error-predicate
      (let ((func (foreign-procedure* int "fdb_error_predicate" int int)))
        (lambda (predicate-test code)
          (fxzero? (func predicate-test code)))))

    ;; (define fdb-network-set-option
    ;;   (let ((func (fdb error "fdb_network_set_option" enum POINTER ffi:int)))
    ;;     (lambda (option value length)
    ;;       (check (func option value length)))))

    (define fdb-select-api-version
      (let ((func (foreign-procedure* int "fdb_select_api_version_impl" int int)))
        (lambda (version)
          (check (func version 630)))))

    (define fdb-setup-network
    ;; TODO: implement network options, requires enums
    ;;
    ;; (define fdb-network-set-option
    ;;   (let ((func (fdb error "fdb_network_set_option" enum POINTER ffi:int)))
    ;;     (lambda (option value length)
    ;;       (check (func option value length)))))

    (define fdb-setup-network!
      (let ((func (foreign-procedure* int "fdb_setup_network")))
        (lambda ()
          (check (func)))))

    (define fdb-run-network
      ;; XXX: Here __collect_safe is required, otherwise the network
      ;; thread will lock the other threads during garbage collection.
      ;; Maybe, disabling GC for the network thread is better?
      (let ((func (foreign-procedure __collect_safe "fdb_run_network" () int)))
        (lambda ()
          (check (func)))))


@@ 138,12 162,14 @@
        (lambda ()
          (check (func)))))


    ;; TODO:
    ;;
    ;; (define fdb-add-network-thread-completion-hook
    ;;   (let ((func (foreign-procedure* int "fdb_add_network_thread_completion_hook" void*)))
    ;;     (lambda (thunk)
    ;;       (check (func (ffi:procedure->pointer ffi:void thunk (list ffi:void)))))))


    (define-ftype %keyvalue
      (packed (struct
               (key void*)


@@ 151,7 177,7 @@
               (value void*)
               (value-length int))))

    (define fdb-future-cancel
    (define fdb-future-cancel!
      (let ((func (foreign-procedure* void "fdb_future_cancel" void*)))
        (lambda (future)
          (func future))))


@@ 174,14 200,22 @@
    (define fdb-future-ready?
      (let ((func (foreign-procedure* int "fdb_future_is_ready" void*)))
        (lambda (future)
          (= 1 (func future)))))
          (fx=? (func future) 1))))

    (define (fdb-future-callback proc)
      (let ((code (foreign-callable (lambda (a b) (proc a)) (void* void*) void)))
      ;; XXX: This mostly a helper.  Only pass the the FUTURE to the
      ;; callback; the DATA is ignored because it can be done with
      ;; Scheme using a closure.
      (let ((code (foreign-callable (lambda (future data) (proc future)) (void* void*) void)))
        ;; It is required to lock CODE to avoid that the garbage
        ;; collector does its job if / when code disappears from
        ;; Scheme code, hence leading to a memory error later when C
        ;; side try to call the callback. CODE must be unlocked when
        ;; it is not anymore useful.
        (lock-object code)
        (foreign-callable-entry-point code)))
        (values code (foreign-callable-entry-point code))))

    (define fdb-future-set-callback
    (define fdb-future-set-callback!
      (let ((func (foreign-procedure* int "fdb_future_set_callback" void* void* void*)))
        (lambda (future code)
          (check (func future code 0)))))


@@ 189,146 223,159 @@
    (define fdb-future-get-error
      (let ((func (foreign-procedure* int "fdb_future_get_error" void*)))
        (lambda (future)
          ;; Even if fdb_future_get_error returns an fdb_error_t, do
          ;; not call check, hence avoid to call raise.  It is the
          ;; responsability of a higher level to respond correctly to
          ;; the error.
          (func future))))

    (define fdb-future-get-int64
      (let ((func (foreign-procedure* int "fdb_future_get_int64" void* void*)))
        (lambda (future)
          (let ((pointer (make-double-pointer)))
            (func future pointer)
            (foreign-ref 'integer-64 pointer 0)))))

    (define (pointer->bytevector pointer length)
      ;; Copy a memory region starting at POINTER of LENGTH into a
      ;; bytevector.
      (let ((out (make-bytevector length)))
        (let loop ((index length))
          (unless (fxzero? index)
            (let ((index (fx- index 1)))
              (bytevector-u8-set! out index (foreign-ref 'unsigned-8 pointer index))
              (loop index))))
        out))

    (define fdb-future-get-key
      (let ((func (foreign-procedure* int "fdb_future_get_key" void* void* int)))
      ;; TODO: FIXME like fdb-future-get-value
      (let ((func (foreign-procedure* int "fdb_future_get_key" void* void* void*)))
        (lambda (future)
          (let ((key (make-double-pointer))
                (length (make-double-pointer)))
            (check (func future key length))
            (let* ((length* (foreign-ref 'int length 0))
                   (out (make-bytevector length*)))
              (let loop ((index 0))
                (unless (= index length*)
                  (bytevector-u8-set! out index (foreign-ref 'unsigned-8 key index))
                  (loop (+ index 1))))
              (foreign-free key)
              (foreign-free length)
              out)))))
            (pointer->bytevector key (foreign-ref 'int length 0))))))

    (define fdb-future-get-value
      (let ((func (foreign-procedure* int "fdb_future_get_value" void* void* void* void*)))
        (lambda (future)
          (let ((present (make-double-pointer))
          (let ((present? (make-double-pointer))
                (value (make-double-pointer))
                (length (make-double-pointer)))
            (check (func future present value length))
            (if (= 0 (foreign-ref 'int present 0))
                (begin
                  (foreign-free present)
                  (foreign-free value)
                  (foreign-free length)
                  #f)
                (let* ((length* (foreign-ref 'int length 0))
                       (out (make-bytevector length*))
                       (value* (dereference value)))
                  (let loop ((index 0))
                    (unless (= index length*)
                      (bytevector-u8-set! out index (foreign-ref 'unsigned-8 value* index))
                      (loop (+ index 1))))
                  (foreign-free present)
                  (foreign-free value)
                  (foreign-free length)
                  out))))))

    (define (key-value->cons pointer)
      (let* ((kv (pointer->ftype %keyvalue pointer))
             (key-length (ftype-ref %keyvalue (key-length) kv))
             (key (make-bytevector key-length))
             (value-length (ftype-ref %keyvalue (value-length) kv))
             (value (make-bytevector value-length)))
        ;; set bytevector key
        (let loop ((index 0))
          (unless (= index key-length)
            (bytevector-u8-set! key
                                index
                                (foreign-ref 'unsigned-8 (ftype-ref %keyvalue (key) kv) index))
            (loop (+ index 1))))
        ;; set bytevector value
        (let loop ((index 0))
          (unless (= index value-length)
            (bytevector-u8-set! value
                                index
                                (foreign-ref 'unsigned-8 (ftype-ref %keyvalue (value) kv) index))
            (loop (+ index 1))))
        (cons key value)))

    (define fdb-future-get-range
            (check (func future present? value length))
            (let ((present? (foreign-ref 'int present? 0))
                  (value (foreign-ref 'void* value 0))
                  (length (foreign-ref 'int length 0)))
              (if (fxzero? present?)
                  #f
                  (pointer->bytevector value length)))))))


    (define fdb-future-get-range-page
      ;; Note the return value more? flag.
      (let ((func (foreign-procedure* void* "fdb_future_get_keyvalue_array" void* void* void* void*)))
        (lambda (future)

          (define (%keyvalue->bytevectors pointer)
            (let* ((kv (make-ftype-pointer %keyvalue pointer))
                   (key-length (ftype-ref %keyvalue (key-length) kv))
                   (value-length (ftype-ref %keyvalue (value-length) kv)))
              (cons (pointer->bytevector (ftype-ref %keyvalue (key) kv) key-length)
                    (pointer->bytevector (ftype-ref %keyvalue (value) kv) value-length))))

          (let ((out (make-double-pointer))
                (count (make-double-pointer))
                 ;; TODO: support different streaming mode
                (more (make-double-pointer)))
            (check (func future out count more))
            (let ((count* (foreign-ref 'int count 0)))
              (let loop ((index (- count* 1))
                         (out* '()))
                (if (= index -1)
                    out*
                    (loop (- index 1)
                          (cons (key-value->cons (+ (dereference out)
                                                    (* index (ftype-sizeof %keyvalue))))
                                out*)))))))))
                (more? (make-double-pointer)))
            (check (func future out count more?))
            ;; Dereference double pointers as soon as possible, since
            ;; they are backed by a bytevector, and GC might reap
            ;; them...
            (let ((out (pointer-dereference out))
                  (count (foreign-ref 'int count 0))
                  (more? (fx=? (foreign-ref 'int more? 0) 1)))
              ;; Iterate in reverse order to avoid a call to the
              ;; procedure reverse.
              (let loopx ((index count)
                          (out* '()))
                (if (fxzero? index)
                    (values out* more?)
                    (let ((index (fx- index 1)))
                      ;; XXX: I think I remember 64bit memory addresses
                      ;; can be bigger than the greatest fixnum, hence +
                      ;; instead of fx+. There might be a way to
                      ;; reference an item in array of structs using
                      ;; Chez form but I do not know what it is.
                      (let ((item (%keyvalue->bytevectors (+ out
                                                             (fx* (ftype-sizeof %keyvalue)
                                                                  index)))))
                        (loopx index (cons item out*)))))))))))

    (define fdb-create-database
      (let ((func (foreign-procedure "fdb_create_database" (string void*) int)))
        (lambda (cluster-file)
        (lambda (maybe-cluster-file)
          (let ((out (make-double-pointer)))
            (func cluster-file out)
            (dereference out)))))
            (check (func maybe-cluster-file out))
            (pointer-dereference out)))))

    (define fdb-database-destroy
      (let ((func (foreign-procedure* void "fdb_database_destroy" void*)))
        (lambda (database)
          (func database))))

    ;; TODO: fdb_database_set_option

    (define fdb-database-create-transaction
      (let ((func (foreign-procedure* int "fdb_database_create_transaction" void* void*)))
        (lambda (database)
          (let ((out (make-double-pointer)))
            (check (func database out))
            (dereference out)))))
            (pointer-dereference out)))))

    (define fdb-transaction-destroy
      (let ((func (foreign-procedure* void "fdb_transaction_destroy" void*)))
        (lambda (transaction)
          (func transaction))))

    (define fdb-transaction-cancel
    (define fdb-transaction-cancel!
      (let ((func (foreign-procedure* void "fdb_transaction_cancel" void*)))
        (lambda (transaction)
          (func transaction))))

    ;; TODO: fdb_transaction_set_option

    ;; TODO: fdb_tranaction_set_read_version

    ;; TODO: fdb_tranaction_get_read_version

    (define fdb-transaction-get
      (let ((func (foreign-procedure* void* "fdb_transaction_get" void* void* int int)))
        (lambda (transaction key snapshot?)
          (with-lock key
            (func transaction
                  (bytevector->pointer key)
                  (bytevector-length key)
                  (if snapshot? 1 0))))))
          (func transaction
                (bytevector-pointer key)
                (bytevector-length key)
                (if snapshot? 1 0)))))

    ;; TODO: fdb_transaction_get_key

    (define fdb-transaction-get-range
    (define fdb-transaction-get-range-page
      ;; https://apple.github.io/foundationdb/api-c.html#c.fdb_transaction_get_range
      (let ((func (foreign-procedure* void*
                                      "fdb_transaction_get_range"
                                      void* ;; tr
                                      void* ;; begin key name
                                      int ;; begin key name length
                                      int ;; begin or equal
                                      int ;; begin offset
                                      int ;; begin's key name length
                                      int ;; begin's or equal
                                      int ;; begin's offset
                                      void* ;; end key name
                                      int ;; end key name length
                                      int ;; end or equal
                                      int ;; end offset
                                      int ;; end's key name length
                                      int ;; end's or equal
                                      int ;; end's offset
                                      int ;; limit
                                      int ;; target bytes
                                      int ;; mode
                                      int ;; iteration
                                      int ;; snapshot
                                      int ;; reverse
                                      int ;; snapshot?
                                      int ;; reverse?
                                      )))
        (lambda (transaction
                 begin-key


@@ 343,25 390,23 @@
                 iteration
                 snapshot?
                 reverse?)
          (with-lock begin-key
            (with-lock end-key
              (func transaction
                    (bytevector->pointer begin-key)
                    (bytevector-length begin-key)
                    (if begin-or-equal? 1 0)
                    begin-offset
                    (bytevector->pointer end-key)
                    (bytevector-length end-key)
                    (if end-or-equal? 1 0)
                    end-offset
                    limit
                    target-bytes
                    mode
                    iteration
                    (if snapshot? 1 0)
                    (if reverse? 1 0)))))))

    (define fdb-transaction-set
          (func transaction
                (bytevector-pointer begin-key)
                (bytevector-length begin-key)
                (if begin-or-equal? 1 0)
                begin-offset
                (bytevector-pointer end-key)
                (bytevector-length end-key)
                (if end-or-equal? 1 0)
                end-offset
                limit
                target-bytes
                mode
                iteration
                (if snapshot? 1 0)
                (if reverse? 1 0)))))

    (define fdb-transaction-set!
      (let ((func (foreign-procedure* void
                                      "fdb_transaction_set"
                                      void* ;; tr


@@ 371,13 416,15 @@
                                      int ;; value length
                                      )))
        (lambda (transaction key value)
          (assert (fx<=? (bytevector-length key) (expt 10 4)))
          (assert (fx<=? (bytevector-length value) (expt 10 5)))
          (func transaction
                (bytevector->pointer key)
                (bytevector-pointer key)
                (bytevector-length key)
                (bytevector->pointer value)
                (bytevector-pointer value)
                (bytevector-length value)))))

    (define fdb-transaction-atomic-op
    (define fdb-transaction-atomic-op!
      (let ((func (foreign-procedure* void
                                      "fdb_transaction_atomic_op"
                                      void* ;; tr


@@ 388,16 435,14 @@
                                      int ;; operation type
                                      )))
        (lambda (transaction key param operation-type)
          (with-lock key
            (with-lock param
              (func transaction
                    (bytevector->pointer key)
                    (bytevector-pointer key)
                    (bytevector-length key)
                    (bytevector->pointer param)
                    (bytevector-pointer param)
                    (bytevector-length param)
                    operation-type))))))
                    operation-type))))

    (define fdb-transaction-clear
    (define fdb-transaction-clear!
      (let ((func (foreign-procedure* void
                                      "fdb_transaction_clear"
                                      void* ;; tr


@@ 405,12 450,11 @@
                                      int ;; key-name length
                                      )))
        (lambda (transaction key)
          (with-lock key
            (func transaction
                  (bytevector->pointer key)
                  (bytevector-length key))))))
                  (bytevector-pointer key)
                  (bytevector-length key)))))

    (define fdb-transaction-clear-range
    (define fdb-transaction-clear-range!
      (let ((func (foreign-procedure* void
                                      "fdb_transaction_clear_range"
                                      void*


@@ 419,25 463,39 @@
                                      void*
                                      int)))
        (lambda (transaction begin end)
          (with-lock begin
            (with-lock end
              (func transaction
                    (bytevector->pointer begin)
                    (bytevector-pointer begin)
                    (bytevector-length begin)
                    (bytevector->pointer end)
                    (bytevector-length end)))))))
                    (bytevector-pointer end)
                    (bytevector-length end)))))

    ;; TODO: fdb_transaction_watch

    (define fdb-transaction-commit
    (define fdb-transaction-commit!
      (let ((func (foreign-procedure* void*
                                      "fdb_transaction_commit"
                                      void*)))
        (lambda (transaction)
          (func transaction))))

    ;; TODO: fdb_transaction_get_commited_version

    ;; TODO: fdb_transaction_get_approximate_size

    (define fdb-transaction-on-error
      (let ((func (foreign-procedure* void*
                                      "fdb_transaction_on_error"
                                      void*
                                      int)))
        (lambda (transaction error)
          (func transaction error))))))
        (lambda (transaction code)
          (func transaction code))))

    (define fdb-transaction-reset!
      (let ((func (foreign-procedure* void "fdb_transaction_reset" void*)))
        (lambda (transaction)
          (func transaction))))

    ;; TODO: fdb_transaction_add_conflict_range

    ;; TODO: fdb_transaction_get_estimated_range_size_bytes
    ))

A src/foundationdb/generator.scm => src/foundationdb/generator.scm +609 -0
@@ 0,0 1,609 @@
(library (foundationdb generator)
  (export generator make-iota-generator make-range-generator
          make-coroutine-generator list->generator vector->generator
          reverse-vector->generator string->generator
          bytevector->generator
          make-for-each-generator make-unfold-generator
          gcons* gappend gcombine gfilter gremove
          gtake gdrop gtake-while gdrop-while
          gdelete gdelete-neighbor-dups gindex gselect
          generator->list generator->reverse-list
          generator->vector generator->vector!  generator->string
          generator-fold generator-for-each generator-find
          generator-count generator-any generator-every generator-unfold
          gflatten ggroup gmap gmerge gstate-filter generator-map->list
          make-accumulator count-accumulator list-accumulator
          reverse-list-accumulator vector-accumulator
          reverse-vector-accumulator vector-accumulator!
          string-accumulator bytevector-accumulator bytevector-accumulator!
          sum-accumulator product-accumulator)

  (import (chezscheme))

  (define (any pred ls)
    (if (null? (cdr ls))
        (pred (car ls))
        ((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls)))))

  ;; list->bytevector
  (define (list->bytevector list)
    (let ((vec (make-bytevector (length list) 0)))
      (let loop ((i 0) (list list))
        (if (null? list)
            vec
            (begin
              (bytevector-u8-set! vec i (car list))
              (loop (+ i 1) (cdr list)))))))


  ;; generator
  (define (generator . args)
    (lambda () (if (null? args)
                   (eof-object)
                   (let ((next (car args)))
                     (set! args (cdr args))
                     next))))

  ;; circular-generator
  (define (circular-generator . args)
    (let ((base-args args))
      (lambda ()
        (when (null? args)
          (set! args base-args))
        (let ((next (car args)))
          (set! args (cdr args))
          next))))


  ;; make-iota-generator
  (define make-iota-generator
    (case-lambda ((count) (make-iota-generator count 0 1))
                 ((count start) (make-iota-generator count start 1))
                 ((count start step) (make-iota count start step))))

  ;; make-iota
  (define (make-iota count start step)
    (lambda ()
      (cond
       ((<= count 0)
        (eof-object))
       (else
        (let ((result start))
          (set! count (- count 1))
          (set! start (+ start step))
          result)))))


  ;; make-range-generator
  (define make-range-generator
    (case-lambda ((start end) (make-range-generator start end 1))
                 ((start) (make-infinite-range-generator start))
                 ((start end step)
                  (set! start (- (+ start step) step))
                  (lambda () (if (< start end)
                                 (let ((v start))
                                   (set! start (+ start step))
                                   v)
                                 (eof-object))))))

  (define (make-infinite-range-generator start)
    (lambda ()
      (let ((result start))
        (set! start (+ start 1))
        result)))



  ;; make-coroutine-generator
  (define (make-coroutine-generator proc)
    (define return #f)
    (define resume #f)
    (define yield (lambda (v) (call/1cc (lambda (r) (set! resume r) (return v)))))
    (lambda () (call/1cc (lambda (cc) (set! return cc)
                                (if resume
                                    (resume (if #f #f))  ; void? or yield again?
                                    (begin (proc yield)
                                           (set! resume (lambda (v) (return (eof-object))))
                                           (return (eof-object))))))))


  ;; list->generator
  (define (list->generator lst)
    (lambda () (if (null? lst)
                   (eof-object)
                   (let ((next (car lst)))
                     (set! lst (cdr lst))
                     next))))


  ;; vector->generator
  (define vector->generator
    (case-lambda ((vec) (vector->generator vec 0 (vector-length vec)))
                 ((vec start) (vector->generator vec start (vector-length vec)))
                 ((vec start end)
                  (lambda () (if (>= start end)
                                 (eof-object)
                                 (let ((next (vector-ref vec start)))
                                   (set! start (+ start 1))
                                   next))))))


  ;; reverse-vector->generator
  (define reverse-vector->generator
    (case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec)))
                 ((vec start) (reverse-vector->generator vec start (vector-length vec)))
                 ((vec start end)
                  (lambda () (if (>= start end)
                                 (eof-object)
                                 (let ((next (vector-ref vec (- end 1))))
                                   (set! end (- end 1))
                                   next))))))


  ;; string->generator
  (define string->generator
    (case-lambda ((str) (string->generator str 0 (string-length str)))
                 ((str start) (string->generator str start (string-length str)))
                 ((str start end)
                  (lambda () (if (>= start end)
                                 (eof-object)
                                 (let ((next (string-ref str start)))
                                   (set! start (+ start 1))
                                   next))))))


  ;; bytevector->generator
  (define bytevector->generator
    (case-lambda ((str) (bytevector->generator str 0 (bytevector-length str)))
                 ((str start) (bytevector->generator str start (bytevector-length str)))
                 ((str start end)
                  (lambda () (if (>= start end)
                                 (eof-object)
                                 (let ((next (bytevector-u8-ref str start)))
                                   (set! start (+ start 1))
                                   next))))))


  ;; make-for-each-generator
                                        ;FIXME: seems to fail test
  (define (make-for-each-generator for-each obj)
    (make-coroutine-generator (lambda (yield) (for-each yield obj))))


  ;; make-unfold-generator
  (define (make-unfold-generator stop? mapper successor seed)
    (make-coroutine-generator (lambda (yield)
                                (let loop ((s seed))
                                  (if (stop? s)
                                      (if #f #f)
                                      (begin (yield (mapper s))
                                             (loop (successor s))))))))


  ;; gcons*
  (define (gcons* . args)
    (lambda () (if (null? args)
                   (eof-object)
                   (if (= (length args) 1)
                       ((car args))
                       (let ((v (car args)))
                         (set! args (cdr args))
                         v)))))


  ;; gappend
  (define (gappend . args)
    (lambda () (if (null? args)
                   (eof-object)
                   (let loop ((v ((car args))))
                     (if (eof-object? v)
                         (begin (set! args (cdr args))
                                (if (null? args)
                                    (eof-object)
                                    (loop ((car args)))))
                         v)))))

  ;; gflatten
  (define (gflatten gen)
    (let ((state '()))
      (lambda ()
        (if (null? state) (set! state (gen)))
        (if (eof-object? state)
            state
            (let ((obj (car state)))
              (set! state (cdr state))
              obj)))))

  ;; ggroup
  (define ggroup
    (case-lambda
      ((gen k)
       (simple-ggroup gen k))
      ((gen k padding)
       (padded-ggroup (simple-ggroup gen k) k padding))))

  (define (simple-ggroup gen k)
    (lambda ()
      (let loop ((item (gen)) (result '()) (count (- k 1)))
        (if (eof-object? item)
            (if (null? result) item (reverse result))
            (if (= count 0)
                (reverse (cons item result))
                (loop (gen) (cons item result) (- count 1)))))))

  (define (padded-ggroup gen k padding)
    (lambda ()
      (let ((item (gen)))
        (if (eof-object? item)
            item
            (let ((len (length item)))
              (if (= len k)
                  item
                  (append item (make-list (- k len) padding))))))))

  ;; gmerge
  (define gmerge
    (case-lambda
      ((< gen) gen)
      ((< genleft genright)
       (let ((left (genleft))
             (right (genright)))
         (lambda ()
           (cond
            ((and (eof-object? left) (eof-object? right))
             left)
            ((eof-object? left)
             (let ((obj right)) (set! right (genright)) obj))
            ((eof-object? right)
             (let ((obj left))  (set! left (genleft)) obj))
            ((< right left)
             (let ((obj right)) (set! right (genright)) obj))
            (else
             (let ((obj left)) (set! left (genleft)) obj))))))
      ((< . gens)
       (apply gmerge <
              (let loop ((gens gens) (gs '()))
                (cond ((null? gens) (reverse gs))
                      ((null? (cdr gens)) (reverse (cons (car gens) gs)))
                      (else (loop (cddr gens)
                                  (cons (gmerge < (car gens) (cadr gens)) gs)))))))))

  ;; gmap
  (define gmap
    (case-lambda
      ((proc gen)
       (lambda ()
         (let ((item (gen)))
           (if (eof-object? item) item (proc item)))))
      ((proc . gens)
       (lambda ()
         (let ((items (map (lambda (x) (x)) gens)))
           (if (any eof-object? items) (eof-object) (apply proc items)))))))

  ;; gcombine
  (define (gcombine proc seed . gens)
    (lambda ()
      (define items (map (lambda (x) (x)) gens))
      (if (any eof-object? items)
          (eof-object)
          (let ()
            (define-values (value newseed) (apply proc (append items (list seed))))
            (set! seed newseed)
            value))))

  ;; gfilter
  (define (gfilter pred gen)
    (lambda () (let loop ()
                 (let ((next (gen)))
                   (if (or (eof-object? next)
                           (pred next))
                       next
                       (loop))))))

  ;; gstate-filter
  (define (gstate-filter proc seed gen)
    (let ((state seed))
      (lambda ()
        (let loop ((item (gen)))
          (if (eof-object? item)
              item
              (let-values (((yes newstate) (proc item state)))
                (set! state newstate)
                (if yes
                    item
                    (loop (gen)))))))))



  ;; gremove
  (define (gremove pred gen)
    (gfilter (lambda (v) (not (pred v))) gen))



  ;; gtake
  (define gtake
    (case-lambda ((gen k) (gtake gen k (eof-object)))
                 ((gen k padding)
                  (make-coroutine-generator (lambda (yield)
                                              (if (> k 0)
                                                  (let loop ((i 0) (v (gen)))
                                                    (begin (if (eof-object? v) (yield padding) (yield v))
                                                           (if (< (+ 1 i) k)
                                                               (loop (+ 1 i) (gen))
                                                               (eof-object))))
                                                  (eof-object)))))))



  ;; gdrop
  (define (gdrop gen k)
    (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen))
            (gen)))



  ;; gdrop-while
  (define (gdrop-while pred gen)
    (define found #f)
    (lambda ()
      (let loop ()
        (let ((val (gen)))
          (cond (found val)
                ((and (not (eof-object? val)) (pred val)) (loop))
                (else (set! found #t) val))))))


  ;; gtake-while
  (define (gtake-while pred gen)
    (lambda () (let ((next (gen)))
                 (if (eof-object? next)
                     next
                     (if (pred next)
                         next
                         (begin (set! gen (generator))
                                (gen)))))))



  ;; gdelete
  (define gdelete
    (case-lambda ((item gen) (gdelete item gen equal?))
                 ((item gen ==)
                  (lambda () (let loop ((v (gen)))
                               (cond
                                ((eof-object? v) (eof-object))
                                ((== item v) (loop (gen)))
                                (else v)))))))



  ;; gdelete-neighbor-dups
  (define gdelete-neighbor-dups
    (case-lambda ((gen)
                  (gdelete-neighbor-dups gen equal?))
                 ((gen ==)
                  (define firsttime #t)
                  (define prev #f)
                  (lambda () (if firsttime
                                 (begin (set! firsttime #f)
                                        (set! prev (gen))
                                        prev)
                                 (let loop ((v (gen)))
                                   (cond
                                    ((eof-object? v)
                                     v)
                                    ((== prev v)
                                     (loop (gen)))
                                    (else
                                     (set! prev v)
                                     v))))))))


  ;; gindex
  (define (gindex value-gen index-gen)
    (let ((done? #f) (count 0))
      (lambda ()
        (if done?
            (eof-object)
            (let loop ((value (value-gen)) (index (index-gen)))
              (cond
               ((or (eof-object? value) (eof-object? index))
                (set! done? #t)
                (eof-object))
               ((= index count)
                (set! count (+ count 1))
                value)
               (else
                (set! count (+ count 1))
                (loop (value-gen) index))))))))


  ;; gselect
  (define (gselect value-gen truth-gen)
    (let ((done? #f))
      (lambda ()
        (if done?
            (eof-object)
            (let loop ((value (value-gen)) (truth (truth-gen)))
              (cond
               ((or (eof-object? value) (eof-object? truth))
                (set! done? #t)
                (eof-object))
               (truth value)
               (else (loop (value-gen) (truth-gen)))))))))

  ;; generator->list
  (define generator->list
    (case-lambda ((gen n)
                  (generator->list (gtake gen n)))
                 ((gen)
                  (reverse (generator->reverse-list gen)))))

  ;; generator->reverse-list
  (define generator->reverse-list
    (case-lambda ((gen n)
                  (generator->reverse-list (gtake gen n)))
                 ((gen)
                  (generator-fold cons '() gen))))

  ;; generator->vector
  (define generator->vector
    (case-lambda ((gen) (list->vector (generator->list gen)))
                 ((gen n) (list->vector (generator->list gen n)))))


  ;; generator->vector!
  (define (generator->vector! vector at gen)
    (let loop ((value (gen)) (count 0) (at at))
      (cond
       ((eof-object? value) count)
       ((>= at (vector-length vector)) count)
       (else (begin
               (vector-set! vector at value)
               (loop (gen) (+ count 1) (+ at 1)))))))


  (define (pk . args)
    (write args)
    (car (reverse args)))
  
  ;; generator->string
  (define generator->string
    (case-lambda ((gen) (list->string (generator->list gen)))
                 ((gen n) (list->string (generator->list gen n)))))




  ;; generator-fold
  (define (generator-fold f seed . gs)
    (define (inner-fold seed)
      (let ((vs (map (lambda (g) (g)) gs)))
        (if (any eof-object? vs)
            seed
            (inner-fold (apply f (append vs (list seed)))))))
    (inner-fold seed))



  ;; generator-for-each
  (define (generator-for-each f . gs)
    (let loop ()
      (let ((vs (map (lambda (g) (g)) gs)))
        (if (any eof-object? vs)
            (if #f #f)
            (begin (apply f vs)
                   (loop))))))


  (define (generator-map->list f . gs)
    (let loop ((result '()))
      (let ((vs (map (lambda (g) (g)) gs)))
        (if (any eof-object? vs)
            (reverse result)
            (loop (cons (apply f vs) result))))))


  ;; generator-find
  (define (generator-find pred g)
    (let loop ((v (g)))
                                        ; A literal interpretation might say it only terminates on #eof if (pred #eof) but I think this makes more sense...
      (if (or (pred v) (eof-object? v))
          v
          (loop (g)))))


  ;; generator-count
  (define (generator-count pred g)
    (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g))


  ;; generator-any
  (define (generator-any pred g)
    (let loop ((v (g)))
      (if (eof-object? v)
          #f
          (if (pred v)
              #t
              (loop (g))))))


  ;; generator-every
  (define (generator-every pred g)
    (let loop ((v (g)))
      (if (eof-object? v)
          #t
          (if (pred v)
              (loop (g))
              #f ; the spec would have me return #f, but I think it must simply be wrong...
              ))))


  ;; generator-unfold
  (define (generator-unfold g unfold . args)
    (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args))


  ;; make-accumulator
  (define (make-accumulator kons knil finalize)
    (let ((state knil))
      (lambda (obj)
        (if (eof-object? obj)
            (finalize state)
            (set! state (kons obj state))))))


  ;; count-accumulator
  (define (count-accumulator) (make-accumulator
                               (lambda (obj state) (+ 1 state)) 0 (lambda (x) x)))

  ;; list-accumulator
  (define (list-accumulator) (make-accumulator cons '() reverse))

  ;; reverse-list-accumulator
  (define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x)))

  ;; vector-accumulator
  (define (vector-accumulator)
    (make-accumulator cons '() (lambda (x) (list->vector (reverse x)))))

  ;; reverse-vector-accumulator
  (define (reverse-vector-accumulator)
    (make-accumulator cons '() list->vector))

  ;; vector-accumulator!
  (define (vector-accumulator! vec at)
    (lambda (obj)
      (if (eof-object? obj)
          vec
          (begin
            (vector-set! vec at obj)
            (set! at (+ at 1))))))

  ;; bytevector-accumulator
  (define (bytevector-accumulator)
    (make-accumulator cons '() (lambda (x) (list->bytevector (reverse x)))))

  (define (bytevector-accumulator! bytevec at)
    (lambda (obj)
      (if (eof-object? obj)
          bytevec
          (begin
            (bytevector-u8-set! bytevec at obj)
            (set! at (+ at 1))))))

  ;; string-accumulator
  (define (string-accumulator)
    (make-accumulator cons '()
                      (lambda (lst) (list->string (reverse lst)))))

  ;; sum-accumulator
  (define (sum-accumulator) (make-accumulator + 0 (lambda (x) x)))

  ;; product-accumulator
  (define (product-accumulator) (make-accumulator * 1 (lambda (x) x)))



  )

A src/foundationdb/helpers.scm => src/foundationdb/helpers.scm +40 -0
@@ 0,0 1,40 @@
(library (foundationdb helpers)
  (export define-record-type* pk)
  (import (chezscheme))

  (define (pk . args)
    (display ";;; ")(write args)(newline)(flush-output-port)
    (car (reverse args)))
  
  (define-syntax define-record-type*
    (lambda (stx)
      (syntax-case stx ()
        ((_ type (constructor constructor-tag ...)
            predicate
            (field-tag accessor setter ...) ...)
         (and (for-all identifier?
                       #'(type constructor constructor-tag ... predicate
                               field-tag ... accessor ... setter ... ...))
              (for-all (lambda (s) (<= 0 (length s) 1))
                       #'((setter ...) ...))
              (for-all (lambda (ct)
                         (memp (lambda (ft) (bound-identifier=? ct ft))
                               #'(field-tag ...)))
                       #'(constructor-tag ...)))
         (with-syntax (((field-clause ...)
                        (map (lambda (clause)
                               (if (= 2 (length clause))
                                   #`(immutable . #,clause)
                                   #`(mutable . #,clause)))
                             #'((field-tag accessor setter ...) ...)))
                       ((unspec-tag ...)
                        (remp (lambda (ft)
                                (memp (lambda (ct) (bound-identifier=? ft ct))
                                      #'(constructor-tag ...)))
                              #'(field-tag ...))))
                      #'(define-record-type (type constructor predicate)
                          (protocol (lambda (ctor)
                                      (lambda (constructor-tag ...)
                                        (define unspec-tag) ...
                                        (ctor field-tag ...))))
                          (fields field-clause ...))))))))

A src/foundationdb/pack.scm => src/foundationdb/pack.scm +283 -0
@@ 0,0 1,283 @@
;; Copyright © 2019 Amirouche BOUBEKKI <amirouche at hyper dev>
;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use,
;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following
;;; conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;; OTHER DEALINGS IN THE SOFTWARE.
;;
;; Based on FoundationDB Python bindings pack and unpack functions
;;
(library (foundationdb pack)

  (export pack unpack *null*)

  (import (chezscheme)
          (foundationdb generator))

  (begin

    (define *null* '(null))

    (define *null-code* #x00)
    ;; variable length
    (define *bytes-code* #x01)
    (define *string-code* #x02)
    (define *symbol-code* #x03)
    (define *nested-code* #x05)
    ;; integers
    (define *neg-int-start* #x0B)
    (define *int-zero-code* #x14)
    (define *pos-int-end* #x1D)
    ;; double
    (define *double-code* #x21)
    ;; true and false
    (define *false-code* #x26)
    (define *true-code* #x27)
    (define *escape-code* #xFF)

    ;; pack

    (define (struct:pack>Q integer)
      (let ((bytevector (make-bytevector 8 0)))
        (let loop ((index 0))
          (unless (= index 8)
            (bytevector-u8-set! bytevector
                                index (bitwise-and
                                       (ash integer (- (* (- 7 index) 8)))
                                       #xFF))
            (loop (+ index 1))))
        bytevector))

    (define (struct:unpack>Q bytevector)
      (let loop ((index 0)
                 (out 0))
        (if (= index 8)
            out
            (loop (+ index 1)
                  (+ out
                     (ash
                      (bytevector-u8-ref bytevector index)
                      (* (- 7 index) 8)))))))

    (define (%%pack-bytes bv accumulator)
      (let loop ((index 0))
        (unless (= index (bytevector-length bv))
          (let ((byte (bytevector-u8-ref bv index)))
            (if (zero? byte)
                (begin ;; escape null byte
                  (accumulator #x00)
                  (accumulator *escape-code*))
                (accumulator byte))
            (loop (+ index 1)))))
      (accumulator #x00))

    (define *bigish* (ash 1 (* 8 8)))

    (define *limits*
      (let ((limits (make-vector 9)))
        (let loop ((index 0))
          (unless (= index 9)
            (vector-set! limits index (- (ash 1 (* index 8)) 1))
            (loop (+ index 1))))
        limits))

    (define (bisect vector value)
      (let loop ((low 0)
                 (high (vector-length vector)))
        (if (>= low high)
            low
            (let ((middle (quotient (+ low high) 2)))
              (if (< (vector-ref vector middle) value)
                  (loop (+ middle 1) high)
                  (loop low middle))))))

    (define (%%pack-positive-integer integer accumulator)
      (if (< integer *bigish*)
          ;; small integer
          (let* ((length (integer-length integer))
                 (n (exact (ceiling (/ length 8))))
                 (bv (struct:pack>Q integer)))
            (accumulator (+ *int-zero-code* n))
            (let loop ((index (- (bytevector-length bv) n)))
              (unless (= index (bytevector-length bv))
                (accumulator (bytevector-u8-ref bv index))
                (loop (+ index 1)))))
          ;; big integer
          (let ((length (exact (floor (/ (+ (integer-length integer) 7) 8)))))
            (accumulator *pos-int-end*)
            (accumulator length)
            (let loop ((index (- length 1)))
              (unless (= index -1)
                (accumulator (bitwise-and (ash integer (- (* 8 index)))
                                          #xFF))
                (loop (- index 1)))))))

    (define (%%pack-negative-integer integer accumulator)
      (if (< (- integer) *bigish*)
          ;; small negative integer
          (let* ((n (bisect *limits* (- integer)))
                 (maxv (vector-ref *limits* n))
                 (bv (struct:pack>Q (+ maxv integer))))
            (accumulator (- *int-zero-code* n))
            (let loop ((index (- (bytevector-length bv) n)))
              (unless (= index (bytevector-length bv))
                (accumulator (bytevector-u8-ref bv index))
                (loop (+ index 1)))))
          ;; big negative integer
          (let* ((length (exact (ceiling (/ (+ (integer-length integer) 7) 8))))
                 (integer (+ integer (- (ash 1 (* length 8)) 1))))
            (accumulator *neg-int-start*)
            (accumulator (bitwise-xor length #xFF))
            (let loop ((index (- length 1)))
              (unless (= index -1)
                (accumulator (bitwise-and (ash integer (- (* 8 index)))
                                          #xFF))
                (loop (- index 1)))))))

    (define (%%pack accumulator)
      (lambda (value)
        (cond
         ((eq? value *null*) (accumulator *null-code*))
         ((eq? value #t) (accumulator *true-code*))
         ((eq? value #f) (accumulator *false-code*))
         ((bytevector? value) (accumulator *bytes-code*) (%%pack-bytes value accumulator))
         ((string? value) (accumulator *string-code*) (%%pack-bytes (string->utf8 value) accumulator))
         ((symbol? value)
          (accumulator *symbol-code*)
          (%%pack-bytes (string->utf8 (symbol->string value)) accumulator))
         ;; integer
         ((and (number? value) (exact? value) (< value 0)) (%%pack-negative-integer value accumulator))
         ((and (number? value) (exact? value) (= value 0)) (accumulator *int-zero-code*))
         ((and (number? value) (exact? value) (> value 0)) (%%pack-positive-integer value accumulator))
         ;;
         (else (error 'pack "unsupported data type" value)))))

    (define (%pack args accumulator)
      (for-each (%%pack accumulator) args))

    (define (pack . args)
      (let ((accumulator (bytevector-accumulator)))
        (%pack args accumulator)
        (accumulator (eof-object))))

    ;; unpack

    (define (list->bytevector list)
      (let ((vec (make-bytevector (length list) 0)))
        (let loop ((i 0) (list list))
          (if (null? list)
              vec
              (begin
                (bytevector-u8-set! vec i (car list))
                (loop (+ i 1) (cdr list)))))))

    (define (unpack-bytes bv position)
      (let loop ((position position)
                 (out '()))
        (if (zero? (bytevector-u8-ref bv position))
            (cond
             ;; end of bv
             ((= (+ position 1) (bytevector-length bv))
              (values (list->bytevector (reverse out)) (+ position 1)))
             ;; escaped null bytes
             ((= (bytevector-u8-ref bv (+ position 1)) *escape-code*)
              (loop (+ position 2) (cons #x00 out)))
             ;; end of string
             (else (values (list->bytevector (reverse out)) (+ position 1))))
            ;; just a byte
            (loop (+ position 1) (cons (bytevector-u8-ref bv position) out)))))

    (define (unpack-positive-integer bv code position)
      (let* ((n (- code 20))
             (sub (make-bytevector 8 0)))
        (let loop ((index 0))
          (unless (= index n)
            (bytevector-u8-set! sub (+ (- 8 n) index) (bytevector-u8-ref bv (+ position 1 index)))
            (loop (+ index 1))))
        (values (struct:unpack>Q sub) (+ position 1 n))))

    (define (unpack-negative-integer bv code position)
      (let* ((n (- 20 code))
             (maxv (vector-ref *limits* n))
             (sub (make-bytevector 8 0)))
        (let loop ((index 0))
          (unless (= index n)
            (bytevector-u8-set! sub (+ (- 8 n) index) (bytevector-u8-ref bv (+ position 1 index)))
            (loop (+ index 1))))
        (values (- (struct:unpack>Q sub) maxv) (+ position 1 n))))

    (define (unpack-bigish-positive-integer bv code position)
      (let ((length (bytevector-u8-ref bv (+ position 1))))
        (values (let loop ((range (iota length))
                           (out 0))
                  (if (null? range)
                      out
                      (loop (cdr range) (+ (ash out 8)
                                           (bytevector-u8-ref bv (+ position 2 (car range)))))))
                (+ position 2 length))))

    (define (unpack-bigish-negative-integer bv code position)
      (let ((length (bitwise-xor (bytevector-u8-ref bv (+ position 1)) #xFF)))
        (values (let loop ((range (iota length))
                           (out 0))
                  (if (null? range)
                      (+ (- out (ash 1 (* length 8))) 1)
                      (loop (cdr range) (+ (ash out 8)
                                           (bytevector-u8-ref bv (+ position 2 (car range)))))))
                (+ position 2 length))))

    (define (unpack bv)
      (let loop ((position 0)
                 (out '()))
        (if (= position (bytevector-length bv))
            (reverse out)
            (let ((code (bytevector-u8-ref bv position)))
              (cond
               ;; null, true, false and zero
               ((= code *null-code*) (loop (+ position 1) (cons *null* out)))
               ((= code *true-code*) (loop (+ position 1) (cons #t out)))
               ((= code *false-code*) (loop (+ position 1) (cons #f out)))
               ((= code *int-zero-code*) (loop (+ position 1) (cons 0 out)))
               ;; variable length
               ((= code *bytes-code*)
                (call-with-values (lambda () (unpack-bytes bv (+ position 1)))
                  (lambda (value position) (loop position (cons value out)))))
               ((= code *string-code*)
                (call-with-values (lambda () (unpack-bytes bv (+ position 1)))
                  (lambda (value position) (loop position (cons (utf8->string value) out)))))
               ((= code *symbol-code*)
                (call-with-values (lambda () (unpack-bytes bv (+ position 1)))
                  (lambda (value position) (loop position (cons (string->symbol (utf8->string value)) out)))))
               ;; integers
               ((and (> code *int-zero-code*) (< code *pos-int-end*))
                (call-with-values (lambda () (unpack-positive-integer bv code position))
                  (lambda (value position) (loop position (cons value out)))))
               ((and (> code *neg-int-start*) (< code *int-zero-code*))
                (call-with-values (lambda () (unpack-negative-integer bv code position))
                  (lambda (value position) (loop position (cons value out)))))
               ((= code *pos-int-end*)
                (call-with-values (lambda () (unpack-bigish-positive-integer bv code position))
                  (lambda (value position) (loop position (cons value out)))))
               ((= code *neg-int-start*)
                (call-with-values (lambda () (unpack-bigish-negative-integer bv code position))
                  (lambda (value position) (loop position (cons value out)))))
               ;; oops
               (else (error 'unpack "unsupported code" code)))))))

    ))

M src/foundationdb/sync.scm => src/foundationdb/sync.scm +82 -105
@@ 1,52 1,19 @@
(library (foundationdb sync)

  (export fdb-init!
          make-fdb
          fdb-open
          fdb-close
          fdb-in-transaction
          fdb-ref
          fdb-set!
          ;; fdb-delete!
          fdb-delete!
          fdb-range
          strinc)

  (import (chezscheme) (foundationdb))
  (import (chezscheme) (foundationdb) (foundationdb helpers))

  (begin

    (define-syntax define-record-type*
      (lambda (stx)
        (syntax-case stx ()
          ((_ type (constructor constructor-tag ...)
              predicate
              (field-tag accessor setter ...) ...)
           (and (for-all identifier?
                         #'(type constructor constructor-tag ... predicate
                                 field-tag ... accessor ... setter ... ...))
                (for-all (lambda (s) (<= 0 (length s) 1))
                         #'((setter ...) ...))
                (for-all (lambda (ct)
                           (memp (lambda (ft) (bound-identifier=? ct ft))
                                 #'(field-tag ...)))
                         #'(constructor-tag ...)))
           (with-syntax (((field-clause ...)
                          (map (lambda (clause)
                                 (if (= 2 (length clause))
                                     #`(immutable . #,clause)
                                     #`(mutable . #,clause)))
                               #'((field-tag accessor setter ...) ...)))
                         ((unspec-tag ...)
                          (remp (lambda (ft)
                                  (memp (lambda (ct) (bound-identifier=? ft ct))
                                        #'(constructor-tag ...)))
                                #'(field-tag ...))))
                        #'(define-record-type (type constructor predicate)
                            (protocol (lambda (ctor)
                                        (lambda (constructor-tag ...)
                                          (define unspec-tag) ...
                                          (ctor field-tag ...))))
                            (fields field-clause ...)))))))

    (define-record-type* <fdb>
      (%make-fdb database)
      fdb?


@@ 61,13 28,13 @@

    (define (fdb-init!)
      (fdb-select-api-version 630)
      ;; setup network thread
      (fdb-setup-network)
      (set! %network-thread
            (fork-thread (lambda () (fdb-run-network)))))
      (fdb-setup-network!)
      (fork-thread (lambda () (fdb-run-network))))

    (define (make-fdb)
      (%make-fdb (fdb-create-database #f)))
    (define fdb-open
      (case-lambda
       (() (fdb-open #f))
       ((cluster-file) (%make-fdb (fdb-create-database cluster-file)))))

    (define (fdb-close fdb)
      (fdb-database-destroy (fdb-database fdb)))


@@ 75,56 42,51 @@
    (define (fdb-transaction-begin fdb)
      (make-transaction (fdb-database-create-transaction (fdb-database fdb))))

    (define (pk . args)
      (write args)(newline)
      (car (reverse args)))

    (define (fdb-future-block-until-ready* future)
      
      (define on-ready 
        (lambda (condition self)
          (condition-signal condition)
          (unlock-object self)))
      
      (unless (fdb-future-ready? future)
        (let ((mutex (make-mutex))
              (condition (make-condition)))
          (letrec* ((code (foreign-callable (lambda (a b) (on-ready condition code)) (void* void*) void)))
            (lock-object code)
            (fdb-future-set-callback future (foreign-callable-entry-point code))
            (mutex-acquire mutex)
            (condition-wait condition mutex)
            (mutex-release mutex)))))
          
        (fdb-future-block-until-ready future)))

    (define (fdb-transaction-commit* transaction)
      (let ((future (fdb-transaction-commit (transaction-pointer transaction))))
      (let ((future (fdb-transaction-commit! (transaction-pointer transaction))))
        (fdb-future-block-until-ready* future)
        (let ((error (fdb-future-get-error future)))
          (fdb-future-destroy future)
          (fdb-transaction-destroy (transaction-pointer transaction))
          error)))

    (define (fdb-transaction-rollback transaction)
      (fdb-transaction-cancel (transaction-pointer transaction))
      (fdb-transaction-cancel! (transaction-pointer transaction))
      (fdb-transaction-destroy (transaction-pointer transaction)))

    (define (fdb-in-transaction fdb proc)
      (let ((tx (fdb-transaction-begin fdb)))
        (let loop ()
          (call-with-values (lambda () (proc tx))
            (lambda out
              (let ((error (fdb-transaction-commit* tx)))
                (if (fxzero? error)
                    (apply values out)
                    (let ((future (fdb-transaction-on-error (transaction-pointer tx) error)))
                      (fdb-future-block-until-ready* future)
                      (let ((error (fdb-future-get-error future)))
                        (fdb-future-destroy future)
                        (if (fxzero? error)
                            (loop)
                            (begin
                              (fdb-transaction-rollback (transaction-pointer tx))
                              (raise (cons 'foundationdb error))))))))))))))
    (define fdb-in-transaction
      (lambda (fdb proc)
        (let ((tx (fdb-transaction-begin fdb)))
          (let retry ((count 5))
            (if (fxzero? count)
                (begin
                  (fdb-transaction-cancel! (transaction-pointer tx))
                  (fdb-transaction-destroy (transaction-pointer tx))
                  (error 'foundationdb "too many retry"))             
                (call-with-values (lambda () (proc tx))
                  (lambda out
                    ;; try to commit
                    (let ((error (fdb-transaction-commit* tx)))
                      (if (fxzero? error)
                          (begin ;; success
                            (fdb-transaction-destroy (transaction-pointer tx))
                            (apply values out))
                          ;; there is an error, retry or raise
                          (let ((future (fdb-transaction-on-error (transaction-pointer tx) error)))
                            (fdb-future-block-until-ready* future)
                            (let ((error (fdb-future-get-error future)))
                              (fdb-future-destroy future)
                              ;; XXX: The official python bindings will
                              ;; neither reset the transaction, nor rollback
                              ;; the failed transaction in case of retry...
                              (if (fxzero? error)
                                  (retry (fx- count 1))
                                  (begin
                                    (fdb-transaction-rollback tx)
                                    (fdb-error error))))))))))))))

    (define (fdb-ref tx key)
      (let ((future (fdb-transaction-get (transaction-pointer tx)


@@ 138,13 100,13 @@
                value)
               (begin
                 (fdb-future-destroy future)
                 (raise (cons 'foundationdb error)))))))
                 (fdb-error error))))))

    (define (fdb-set! tx key value)
      (fdb-transaction-set (transaction-pointer tx) key value))
      (fdb-transaction-set! (transaction-pointer tx) key value))

    (define (fdb-delete! transaction key)
      (fdb-transaction-clear (transaction-pointer transaction) key))
      (fdb-transaction-clear! (transaction-pointer transaction) key))

    (define (fdb-range transaction
                       start-key


@@ 152,26 114,41 @@
                       end-key
                       end-include?
                       reverse?)
      (let ((future (fdb-transaction-get-range (transaction-pointer transaction)
                                               start-key
                                               start-include?
                                               0
                                               end-key
                                               end-include?
                                               1
                                               0
                                               0
                                               -2 ;; WANT_ALL
                                               0
                                               #f
                                               reverse?)))
        (fdb-future-block-until-ready* future)
        (let ((error (fdb-future-get-error future)))
          (if (fxzero? error)
              (let ((range (fdb-future-get-range future)))
                (fdb-future-destroy future)
                range)
              (raise (cons 'foundationdb error))))))
      (let iterate ((iteration 0)
                    (start-include? start-include?)
                    (start-key start-key)
                    (out '()))
        ;; XXX: Key selectors are a pain
        ;; ref: https://apple.github.io/foundationdb/api-c.html#key-selectors
        (let ((future (fdb-transaction-get-range-page (transaction-pointer transaction)
                                                      start-key
                                                      start-include?
                                                      1
                                                      end-key
                                                      end-include?
                                                      0
                                                      -1
                                                      -1
                                                      -2 ;; WANT_ALL
                                                      iteration
                                                      #f
                                                      reverse?)))
          (fdb-future-block-until-ready* future)
          (let ((error (fdb-future-get-error future)))
            (if (fxzero? error)
                (call-with-values (lambda () (fdb-future-get-range-page future))
                  (lambda (range more?)
                    (fdb-future-destroy future)
                    (if more?
                        (iterate (fx+ iteration 1)
                                 #t
                                 ;; TODO: do better than this.
                                 (caar (reverse range))
                                 (append out range))
                        (append out range))))
                (begin
                  (fdb-future-destroy future)
                  (fdb-error error)))))))

    (define (strinc bytevector)
      "Return the first bytevector that is not prefix of BYTEVECTOR"


@@ 187,4 164,4 @@
              (loop (cdr out))
              (set! bytes out)))
        ;; increment first byte, reverse and return the bytevector
        (u8-list->bytevector (reverse (cons (+ 1 (car bytes)) (cdr bytes)))))))
        (u8-list->bytevector (reverse (cons (+ 1 (car bytes)) (cdr bytes))))))))

M src/index.scm => src/index.scm +3 -5
@@ 21,12 21,10 @@

  (define (index-open)
    (fdb-init!)
    (make-fdb))
    (fdb-open))

  (define (index-forward-set! db uid url sxml)
    (define s (pack url (scm->bytevector sxml)))
    (bytevector-length s)
    (fdb-set! db (pack *forward* uid) s))
  (define (index-forward-set! db url sxml)
    (fdb-set! db (pack *forward* url) (scm->bytevector sxml)))

  (define (index-forward-ref db uid)
    (call-with-values (lambda () (apply values (unpack (fdb-ref db (pack *forward* uid)))))