(require-library 'sisc/libs/srfi/srfi-1)
(require-library 'sisc/libs/srfi/srfi-9)
(require-library 'sisc/libs/srfi/srfi-11)
(require-library 'sisc/libs/srfi/srfi-13)
(require-library 'sisc/libs/srfi/srfi-42)

(require-library 'lshift/jcollection-ec)
(require-library 'lshift/bdb/bdb-tuple)
(require-library 'lshift/bdb/bdb)
(require-library 'lshift/bdb/bdb-ec)
(require-library 'lshift/bdb/bdb-util)

(import srfi-11)

(import string-io)
(import debugging)
(import threading)

(define (with-basic-java-fc proc)
  (with/fc (lambda (m k)
	     (import s2j)
	     (define-generic-java-methods print-stack-trace)
	     (print-stack-trace (cdr (assq 'message m))))
    proc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import* lshift/bdb/bdb open-environment open-database open-sequence)

(define ee (open-environment "../../test-database"
			     `((allow-create #t)
			       (transactional #t))))

(define tt (open-database ee "tt" `((allow-create #t)
				    (sorted-duplicates #t)
				    (transactional #t))))
(define jj (open-database ee "jj" `((allow-create #t)
				    (sorted-duplicates #t)
				    (transactional #t))))
(define all-sequences-db (open-database ee "all-sequences-db"
					`((allow-create #t)
					  (transactional #t))))
(define ss (open-sequence all-sequences-db 'ss `((allow-create #t))))
(define jjs (open-sequence all-sequences-db '(sequence-for "jj") `((allow-create #t))))

(module very-basic-examples (fill-tt!
			     fill-jj!
			     query-tt
			     query-jj
			     query-jj*)

  (import srfi-42)
  (import lshift/bdb/bdb)
  (import lshift/bdb/bdb-ec)
  (import lshift/bdb/bdb-util)

  (define (fill-tt!)
    (define (p! a b) (database-put! tt a b))
    (p! "john" 15)
    (p! "john" 29)
    (p! "john" 50)
    (p! "jane" 31))

  (define (fill-jj!)
    (import s2j)
    (database-put! jj 'a (->jstring "first"))
    (database-put! jj 'a (->jstring "second"))
    (database-put! jj 'b (->jstring "third")))

  (define (query-tt)
    (list-ec (:database k v tt)
	     (begin (display (format "Outer of    ~a/~a\n" k v)))
	     (if (odd? v))
	     (:search-key v2 (index counter2) k tt)
	     (begin (display (format "Considering ~a/~a, /~a (~a)\n" k v v2 counter2)))
	     (list k (list counter2 v2) v)))

  (define (query-jj)
    (do-ec (:database k v jj)
	   (display (format "~a -> ~a\n" k v))))

  (define (query-jj*)
    (do-ec (:database* k v jj)
	   (display (format "~a -> ~a\n"
			    (database-entry->string k)
			    (database-entry->string v))))))

(import very-basic-examples)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module person-example (get-person-by-id
			get-people-by-name
			get-person-by-login
			get-all-people

			make-person!
			update-person!
			delete-person!

			person-id
			person-name
			person-login
			set-person-name!
			set-person-login!

			(:person by-id))

  (import srfi-42)
  (import lshift/bdb/bdb)
  (import lshift/bdb/bdb-ec)

  (define-syntax :person
    (syntax-rules ()
      ((_ (cc0 cc ...) (id name login))
       ;; This seems like a not-such-a-good idea. Do any other
       ;; generators analyse the structure of their continuation like
       ;; this?
       (:database (cc0 (let ((name (person-name v))
			     (login (person-login v)))
			 cc ...))
		  id v (force by-id)))
      ((_ cc v)
       (:database cc k v (force by-id)))))

  (define by-id (delay (open-database ee "people-by-id" `((allow-create #t)
							  (transactional #t)))))
  (define by-name (delay (open-secondary-database ee "people-by-name" (force by-id)
						  `((allow-create #t)
						    (transactional #t)
						    (sorted-duplicates #t)
						    (key-creator
						     ,(secondary-key-creator
						       (lambda (_ k v)
							 (person-name v))))))))
  (define by-login (delay (open-secondary-database ee "people-by-login" (force by-id)
						   `((allow-create #t)
						     (transactional #t)
						     (key-creator
						      ,(secondary-key-creator
							(lambda (_ k v)
							  (person-login v))))))))
  (define id-seq (delay (open-sequence all-sequences-db '(people-by-id . id)
				       `((allow-create #t)))))

  (define (make-person! name login)
    (require-transaction
     (let ((p (vector (sequence-get (force id-seq))
		      name
		      login)))
       (database-put! (force by-id) (person-id p) p)
       p)))

  (define (update-person! p)
    (database-put! (force by-id) (person-id p) p))

  (define (person-id p) (vector-ref p 0))
  (define (person-name p) (vector-ref p 1))
  (define (person-login p) (vector-ref p 2))
  (define (set-person-name! p v) (vector-set! p 1 v) p)
  (define (set-person-login! p v) (vector-set! p 2 v) p)

  (define (get-person-by-id id)
    (database-get (force by-id) id (lambda _ #f)))

  (define (get-people-by-name name)
    (list-ec (:search-key p name (force by-name)) p))

  (define (get-person-by-login login)
    (database-get (force by-login) login (lambda _ #f)))

  (define (get-all-people)
    (list-ec (:database id p (force by-id)) p))

  (define (delete-person! p)
    (database-delete! (force by-id) (person-id p)))

  (force by-id)
  (force by-name)
  (force by-login)
  (force id-seq))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(display "BDB-SISC server\n")