(define $current-ldap-session (make-fluid #f))

(define (current-ldap-session)
  (fluid $current-ldap-session))

(define (with-ldap-session session thunk)
  (let-fluid $current-ldap-session session thunk))

(import-lambda-definition ldap-session-free
  (session) 
  "scsh_ldap_memfree")

(define (ldap-session-finalizer session)
  (if (ldap-session-bound? session)
      (if (not (ldap-session-implicit-unbind-ok? session))
	  (raise (condition (&ldap-implicit-unbind (session session))))
	  (if (ldap-session-auto-unbind? session)
	      (ldap-unbind session)))))

(import-lambda-definition ldap-init-internal 
  (host port) 
  "scsh_ldap_init")

(define (ldap-init host-name-or-list . args)
  (let-optionals args 
      ((port 0) ; use default port
       (implicit-unbind-ok? #f)
       (unbind-automatically? #t))
    (let ((hosts (if (list? host-name-or-list)
		     (string-join host-name-or-list)
		     host-name-or-list)))
      (let ((session (ldap-init-internal hosts port))
	    (options (make-session-options implicit-unbind-ok? 
					   unbind-automatically?)))
	(add-finalizer! session ldap-session-finalizer)
	(set-ldap-session-bound?! session #f)
	(set-ldap-session-options! session options)
	(set-ldap-session-messages! session '())
	session))))

;;; SIMPLE_BIND_S

(import-lambda-definition ldap-simple-bind-internal 
  (session user cred) 
  "scsh_ldap_simple_bind_s")

(define (ldap-simple-bind user password . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((ret-obj 
	   (convert-ldap-return-code
	    (ldap-simple-bind-internal session user password))))
      (if (ldap-success? ret-obj)
	  (set-ldap-session-bound?! session #t)
	  (raise-ldap-condition ret-obj session)))))

(define (ldap-simple-bind-as-nobody . args)
  (let-optionals args ((session . (current-ldap-session)))
    (ldap-simple-bind #f #f session)))

;;; SASL_BIND_S

;;; FIXME: Need interface to BER-elements before this functions is
;;; usable

(import-lambda-definition ldap-sasl-bind-internal
  (session dn mechanism cred server-controls client-controls server-cred)
  "scsh_ldap_sasl_bind_s")

(define (ldap-sasl-bind session dn mechanism cred 
			server-controls client-controls
			credentials)
  (raise (condition (&ldap-bindings-not-implemented 
		     (what '(ldap-sasl-bind ldap-controls))))))

;;; UNBIND_S

(import-lambda-definition ldap-unbind-internal 
  (session) 
  "scsh_ldap_unbind_s")

(define (ldap-unbind . args)
  (let-optionals args ((session . (current-ldap-session)))
    (let ((ret-obj 
	   (convert-ldap-return-code (ldap-unbind-internal session))))
      (if (ldap-success? ret-obj)
	  (set-ldap-session-bound?! session #f)
	  (raise-ldap-condition ret-obj session)))))

;;; SEARCH_S and SEARCH_ST

(import-lambda-definition ldap-search-internal
  (session base scope filter attribute-list attributes-only?)
  "scsh_ldap_search_s")

(import-lambda-definition ldap-search-with-timeout-internal
  (session base scope filter attribute-list attributes-only? timeout-sec timeout-usec)
  "scsh_ldap_search_st")

(import-lambda-definition ldap-msgfree-internal 
  (message) 
  "scsh_ldap_msgfree")

(define (ldap-message-finalizer message)
  (ldap-msgfree-internal message))

(define (ldap-attribute-list-kludge attribute-list)
  (cond ((eq? attribute-list ldap-attributes-no-attribute)
	 (list ldap-attributes-no-attribute))
	((eq? attribute-list ldap-attributes-all-user-attributes)
	 (list ldap-attributes-all-user-attributes))
	(else attribute-list)))

(define (ldap-search base scope filter attribute-list attributes-only? . args)
  (let-optionals args ((session (current-ldap-session))
		       (timeout-seconds #f) 
		       (timeout-microseconds #f))
    (let ((scope-id (ldap-scope-arguments-id scope))
	  (attr-list (ldap-attribute-list-kludge attribute-list)))
      (call-with-values
       (lambda ()
	 (apply values 
		(if (not timeout-seconds)
		    (ldap-search-internal
		     session base scope-id filter attr-list attributes-only?)
		    (ldap-search-with-timeout-internal
		     session base scope-id filter attr-list attributes-only?
		     timeout-seconds (or timeout-microseconds 0)))))
       (lambda (ret-code message)
	 (let ((ret-obj 
		(convert-ldap-return-code ret-code)))
	   (if (ldap-success? ret-obj)
	       (begin
		 (ldap-session-messages-adjoin! session message)
		 (add-finalizer! message ldap-message-finalizer)
		 (make-ldap-entry message))
	       (raise-ldap-condition ret-obj session))))))))

;;; GET/SET session options

(import-lambda-definition ldap-get-set-option-internal
  (session option set? value)
  "scsh_ldap_get_set_option")

(define (set-ldap-session-option! session-option value . args)
  (let-optionals args ((session (current-ldap-session)))
    (call-with-values
     (lambda ()
       (apply values
	      (ldap-get-set-option-internal 
	       session (ldap-session-option-value-id session-option) #t value)))
     (lambda (call-successful? result)
       (if call-successful?
	   result
	   (raise 
	    (condition (&ldap-session-option-error (session session)))))))))

(define (ldap-session-option session-option . args)
  (let-optionals args ((session (current-ldap-session)))
    (call-with-values
     (lambda ()
       (apply values
	      (ldap-get-set-option-internal
	       session (ldap-session-option-value-id session-option) #f #f)))
     (lambda (call-successful? result)
       (if call-successful?
	   result
	   (raise
	    (condition (&ldap-session-option-error (session session)))))))))

;;; 

(import-lambda-definition ldap-error-string-internal 
  (session error-code) 
  "scsh_ldap_error_string")

(define (ldap-get-error-return-object session)
  (convert-ldap-return-code
   (ldap-session-option (ldap-session-option-value error-number) session)))

;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES

(import-lambda-definition ldap-first-message-internal
  (session message) 
  "scsh_ldap_first_message")

(define (ldap-first-message message . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-first-message-internal session message)
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

(import-lambda-definition ldap-next-message-internal
  (session message) 
  "scsh_ldap_next_message")

(define (ldap-next-message message . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-next-message-internal session message)
	(raise-ldap-condition
	 (ldap-get-error-return-object session) session))))

(import-lambda-definition ldap-count-messages-internal
  (session message) 
  "scsh_ldap_count_messages")

(define (ldap-count-messages message . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((ret (ldap-count-messages-internal session message)))
      (or ret
	  (raise-ldap-condition (ldap-get-error-return-object session) session)))))

;;;

;;; FIXME: Do we need this function if we introduce types for the
;;; diffrent ldap-messages?

(import-lambda-definition ldap-get-message-type-internal
  (message)
  "scsh_ldap_msgtype")

(define (ldap-get-message-type session message)
  (cond 
   ((ldap-get-message-type-internal message)
    => (lambda (code) (convert-ldap-message-type code)))
   (else 
    (raise-ldap-condition (ldap-get-error-return-object session) session))))

;;;

(import-lambda-definition ldap-message-id-internal 
  (message)
  "scsh_ldap_msgid")

(define (ldap-get-message-id message . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-message-id-internal message)
	(raise-ldap-condition (ldap-get-error-return-object session) session))))
			     
;;;

(import-lambda-definition ldap-first-attribute-internal
  (session entry)
  "scsh_ldap_first_attribute")

(import-lambda-definition ldap-next-attribute-internal
  (session entry ber-element)
  "scsh_ldap_next_attribute")

(import-lambda-definition ber-element-free
  (ber-element fbuf)
  "scsh_ldap_ber_free")

(define (ber-element-finalizer ber-element)
  (ber-element-free ber-element 1))

(define (ldap-first-attribute entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (call-with-values
     (lambda ()
       (apply values
	      (ldap-first-attribute-internal session (ldap-entry-message entry))))
     (lambda (attribute-name ber-element)
       (if attribute-name
	   (begin
	     (add-finalizer! ber-element ber-element-finalizer)
	     (values attribute-name ber-element))
	   (raise-ldap-condition (ldap-get-error-return-object session) session))))))

(define (ldap-next-attribute entry ber-element . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-next-attribute-internal session (ldap-entry-message entry) ber-element)
	(let ((ret-obj (ldap-get-error-return-object session)))
	  (if (ldap-success? ret-obj)
	      #f
	      (raise-ldap-condition ret-obj session))))))

(define (ldap-all-attributes entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (call-with-values
     (lambda ()
       (ldap-first-attribute entry session))
     (lambda (first-attribute ber-element)
       (let loop ((next (ldap-next-attribute entry ber-element session))
		  (attributes (list first-attribute)))
	 (if next
	     (loop (ldap-next-attribute entry ber-element session)
		   (cons next attributes))
	     attributes))))))

;;;

(import-lambda-definition ldap-get-values-internal
  (session entry attribute)
  "scsh_ldap_get_values")

(define (ldap-get-values entry attribute-name . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((val (ldap-get-values-internal 
		session (ldap-entry-message entry) attribute-name)))
      (or val 
	  (let ((ret-obj (ldap-get-error-return-object session)))
	    (if (ldap-success? ret-obj)
		val
		(raise-ldap-condition ret-obj session)))))))

;;;

(import-lambda-definition ldap-compare-internal 
  (session dn attribute value) 
  "scsh_ldap_compare_s")

(define (ldap-compare dn attribute value . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((ret-obj 
	   (convert-ldap-return-code
	    (ldap-compare-internal session dn attribute value))))
      (if (or (equal? (ldap-return compare-true) ret-obj)
	      (equal? (ldap-return compare-false) ret-obj))
	  (equal? (ldap-return compare-true) ret-obj)
	  (raise-ldap-condition ret-obj session)))))

;;;

(import-lambda-definition ldap-get-dn-internal
  (session message)
  "scsh_ldap_get_dn")

(define (ldap-entry-dn entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-get-dn-internal session (ldap-entry-message entry))
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

;;;

(import-lambda-definition ldap-explode-dn-internal
  (dn no-types?) 
  "scsh_ldap_explode_dn")

(define (ldap-explode-dn dn no-types? . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-explode-dn-internal dn no-types?)
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

;;;

(import-lambda-definition ldap-explode-rdn-internal
  (dn no-types?) 
  "scsh_ldap_explode_rdn")

(define (ldap-explode-rdn dn no-types? . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-explode-rdn-internal dn no-types?)
	(raise-ldap-condition 
	 (ldap-get-error-return-object session dn no-types?)))))

;;;

(import-lambda-definition ldap-dn2ufn-internal
  (dn)
  "scsh_ldap_dn2ufn")

(define (ldap-make-dn-userfriendly dn . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-dn2ufn-internal dn)
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

;;;

(import-lambda-definition ldap-count-entries-internal
  (session message)
  "scsh_ldap_count_entries")

(import-lambda-definition ldap-first-entry-internal
  (session message)
  "scsh_ldap_first_entry")

(import-lambda-definition ldap-next-entry-internal
  (session message)
  "scsh_ldap_next_entry")

(define (ldap-count-entries entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-count-entries-internal session (ldap-entry-message entry))
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

(define (ldap-first-entry entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (cond 
     ((ldap-first-entry-internal session (ldap-entry-message entry))
      => (lambda (new-message)
	   (add-finalizer! new-message ldap-message-finalizer)
	   (make-ldap-entry new-message)))
     (else
      (let ((ret-obj (ldap-get-error-return-object session)))
	(if (ldap-success? ret-obj)
	    #f
	    (raise-ldap-condition ret-obj session)))))))

(define (ldap-next-entry entry . args)
  (let-optionals args ((session (current-ldap-session)))
    (cond 
     ((ldap-next-entry-internal session (ldap-entry-message entry))
      => (lambda (new-message)
	   (add-finalizer! new-message ldap-message-finalizer)
	   (make-ldap-entry new-message)))
     (else
      (let ((ret-obj (ldap-get-error-return-object session)))
	(if (ldap-success? ret-obj)
	    #f
	    (raise-ldap-condition ret-obj session)))))))

;;;

(import-lambda-definition ldap-count-references-internal
  (session message)
  "scsh_ldap_count_references")

(import-lambda-definition ldap-first-reference-internal
  (session message) 
  "scsh_ldap_first_reference")

(import-lambda-definition ldap-next-reference-internal 
  (session message)
  "scsh_ldap_next_reference")

(define (ldap-count-references message . args)
  (let-optionals args ((session (current-ldap-session)))
    (or (ldap-count-references-internal session message)
	(raise-ldap-condition (ldap-get-error-return-object session) session))))

(define (ldap-first-reference message . args)
  (let-optionals args ((session (current-ldap-session)))
    (cond
     ((ldap-first-reference-internal session message)
      => (lambda (new-message)
	   (add-finalizer! new-message ldap-message-finalizer)
	   new-message))
     (else
      (let ((ret-obj (ldap-get-error-return-object session)))
	(if (ldap-success? ret-obj)
	    #f
	    (raise-ldap-condition ret-obj session)))))))

(define (ldap-next-reference message . args)
  (let-optionals args ((session (current-ldap-session)))
    (cond 
     ((ldap-next-reference-internal session message)
      => (lambda (new-message)
	   (add-finalizer! new-message ldap-message-finalizer)
	   new-message))
     (else
      (let ((ret-obj (ldap-get-error-return-object session)))
	(if (ldap-success? ret-obj)
	    #f
	    (raise-ldap-condition ret-obj session)))))))

;;;

(import-lambda-definition ldap-modify-internal
  (session dn ldap-modification-vector)
  "scsh_ldap_modify")

(define (ldap-modify dn ldap-modifications . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((vec (if (list? ldap-modifications)
		   (list->vector ldap-modifications)
		   (vector ldap-modifications))))
      (let ((ret-obj 
	     (convert-ldap-return-code (ldap-modify-internal session dn vec))))
	(or (ldap-success? ret-obj)
	    (raise-ldap-condition ret-obj session))))))

;;;

(import-lambda-definition ldap-add-internal
  (session dn ldap-modification-vector) 
  "scsh_ldap_add")

(import-lambda-definition ldap-delete-internal
  (session dn)
  "scsh_ldap_delete")

(import-lambda-definition ldap-abandon-internal
  (session message-id)
  "scsh_ldap_abandon")