scsh-ldap/scheme/ldap.scm

(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 port . args)
  (let-optionals args 
      ((implicit-unbind-ok? #f)
       (unbind-automatically? #t))
    (let ((session (ldap-init-internal host-name port))
	  (options (make-session-options implicit-unbind-ok? 
					 unbind-automatically?)))
      (add-finalizer! ldap-session-finalizer session)
      (set-ldap-session-bound?! session #f)
      (set-ldap-session-options! session options)
      session)))

;;; SIMPLE_BIND_S

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

(define (ldap-simple-bind session user password)
  (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))))

;;; SASL_BIND_S

(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 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 session base scope filter attribute-list attributes-only? . args)
  (let-optionals args ((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 filter attr-list attributes-only?)
		    (ldap-search-with-timeout-internal
		     session base scope 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)
		 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 session-option value)
  (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 session-option)
  (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)
  (ldap-session-option session 
		       (ldap-session-option-value error-number)))

;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES

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

(define (ldap-first-message session message)
  (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 session message)
  (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 session message)
  (let ((ret (ldap-count-messages-internal session message)))
    (or ret
	(raise-ldap-condition (ldap-get-error-return-object session) session))))

;;;

(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 session message)
  (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 session entry)
  (call-with-values
   (lambda ()
     (apply values
	    (ldap-first-attribute-internal session 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 session entry ber-element)
  (or (ldap-next-attribute-internal session 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 session entry)
  (call-with-values
   (lambda ()
     (ldap-first-attribute session entry))
   (lambda (first-attribute ber-element)
     (let loop ((next (ldap-next-attribute session entry ber-element))
		(attributes (list first-attribute)))
       (if next
	   (loop (ldap-next-attribute session entry ber-element)
		 (cons next attributes))
	   attributes)))))

;;;

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

(define (ldap-get-values session entry attribute-name)
  (or (ldap-get-values-internal session entry attribute-name)
      (raise-ldap-condition (ldap-get-error-return-object session) session)))

;;;

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

(define (ldap-compare session dn attribute value)
  (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-message-dn session entry)
  (or (ldap-get-dn-internal session 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 session dn no-types?)
  (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 session dn no-types?)
  (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 session dn)
  (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 session message)
  (or (ldap-count-entries-internal session message)
      (raise-ldap-condition (ldap-get-error-return-object session) session)))

(define (ldap-first-entry session message)
  (cond 
   ((ldap-first-entry-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-entry session message)
  (cond 
   ((ldap-next-entry-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-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 session message)
  (or (ldap-count-references-internal session message)
      (raise-ldap-condition (ldap-get-error-return-object session) session)))

(define (ldap-first-reference session message)
  (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 session message)
  (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 session dn ldap-modifications)
  (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")