~amirouche/ruse-babeltoy

bf724338095cfa1a4080e60a563345dcb7f0aa22 — Amirouche 1 year, 1 month ago cfe490a
wip
3 files changed, 56 insertions(+), 29 deletions(-)

M babeltoy.scm
M src/foundationdb.scm
M src/foundationdb/sync.scm
M babeltoy.scm => babeltoy.scm +12 -9
@@ 241,17 241,18 @@

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

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

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

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

  (for-each add! tokens)
  (pk 'wip))
  (pk 'wip uid))

(define (string-contains? string char)
  (let loop ((index (string-length string)))


@@ 271,12 272,12 @@
        (let* ((sxml (html->sxml (cadr uri+body)))
               (tokens (string->tokens (sxml->human-readable-text sxml))))
          (display ".")(flush-output-port)
          (fdb-in-transaction db
                              (lambda (tx)
                                (index! tx
                                        (car uri+body)
                                        sxml
                                        tokens))))))
          (pk 'out (fdb-in-transaction db
                                       (lambda (tx)
                                         (index! tx
                                                 (car uri+body)
                                                 sxml
                                                 tokens)))))))

  (define (f _)
    (display "o")(flush-output-port))


@@ 288,8 289,10 @@
  (call-with-binary-input-port filepath
    (lambda (port)
      (define warc (warc-generator (binary-port->byte-generator port)))
      (pk 'entering (warc))
      (let loop ((item (warc)))
        (unless (eof-object? item)
          (pk item)
          (p item)
          (loop (warc)))))))


M src/foundationdb.scm => src/foundationdb.scm +10 -10
@@ 21,8 21,8 @@
   fdb-future-destroy
   fdb-future-block-until-ready
   fdb-future-ready?
   ;; fdb-future-callback
   ;; fdb-future-set-callback
   fdb-future-callback
   fdb-future-set-callback
   fdb-future-get-error
   fdb-future-get-key
   fdb-future-get-value


@@ 176,15 176,15 @@
        (lambda (future)
          (= 1 (func future)))))

    ;; (define (fdb-future-callback proc)
    ;;   (let ((code (foreign-callable (lambda (a b) (proc a)) (void* void*) void)))
    ;;     (lock-object code)
    ;;     (foreign-callable-entry-point code)))
    (define (fdb-future-callback proc)
      (let ((code (foreign-callable (lambda (a b) (proc a)) (void* void*) void)))
        (lock-object code)
        (foreign-callable-entry-point code)))

    ;; (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)))))
    (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)))))

    (define fdb-future-get-error
      (let ((func (foreign-procedure* int "fdb_future_get_error" void*)))

M src/foundationdb/sync.scm => src/foundationdb/sync.scm +34 -10
@@ 63,7 63,7 @@
      (fdb-select-api-version 630)
      ;; setup network thread
      (fdb-setup-network)
      (set! %network-thread (fork-thread fdb-run-network)))
      (set! %network-thread (fork-thread (lambda () (fdb-run-network)))))

    (define (make-fdb)
      (%make-fdb (fdb-create-database #f)))


@@ 77,29 77,53 @@
    (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)))
      (pk 'ready?)
      (unless (pk 'ready (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)
            (mutex-acquire mutex)
            (condition-wait condition mutex)
            (mutex-release mutex)
            (fdb-future-set-callback (foreign-callable-entry-point code))))))
          
    (define (fdb-transaction-commit* transaction)
      (let ((future (fdb-transaction-commit (transaction-pointer transaction))))
        (fdb-future-block-until-ready future)
        (pk 'bloking-commit)
        (fdb-future-block-until-ready* future)
        (pk 'unblock)
        (let ((error (fdb-future-get-error future)))
          (pk 'error error)
          (fdb-future-destroy future)
          (fdb-transaction-destroy (transaction-pointer transaction))
          error)))
          (pk 'error2 error))))

    (define (fdb-transaction-rollback 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 ((tx (pk (fdb-transaction-begin fdb))))
        (let loop ()
          (pk 'loop)
          (call-with-values (lambda () (proc tx))
            (lambda out
              (pk 'commiting)
              (let ((error (fdb-transaction-commit* tx)))
                (if (fxzero? error)
                    (apply values out)
                (pk 'error 'again error)
                (if (pk (fxzero? error))
                    (apply values (pk out))
                    (let ((future (fdb-transaction-on-error (transaction-pointer tx) error)))
                      (fdb-future-block-until-ready future)
                      (pk 'block)
                      (fdb-future-block-until-ready* future)
                      (let ((error (fdb-future-get-error future)))
                        (fdb-future-destroy future)
                        (if (fxzero? error)


@@ 112,7 136,7 @@
      (let ((future (fdb-transaction-get (transaction-pointer tx)
                                         key
                                         #f)))
        (fdb-future-block-until-ready future)
        (fdb-future-block-until-ready* future)
        (let ((error (fdb-future-get-error future)))
          (if (fxzero? error)
              (let ((value (fdb-future-get-value future)))


@@ 147,7 171,7 @@
                                               0
                                               #f
                                               reverse?)))
        (fdb-future-block-until-ready future)
        (fdb-future-block-until-ready* future)
        (let ((error (fdb-future-get-error future)))
          (if (fxzero? error)
              (let ((range (fdb-future-get-range future)))