scsh-ldap/scheme/ldap.scm

(define ddisplay
  (lambda lst
    (for-each 
     (lambda (x)
       (cond
	((ldap-message? x)
	 (display (number->string (ldap-message-c-pointer x) 16)))
	((ber-element? x)
	 (display (number->string (ber-element-c-pointer x) 16)))
	((ldap-session? x)
	 (display (number->string (ldap-session-c-pointer x) 16)))
	(else
	 (display x))))
     lst)
    (newline)
    (force-output (current-output-port))))

(define *object-table*
  (make-value-weak-table))

(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)
  (ddisplay "FREE ldap-session " session)
  (if (ldap-session-bound? session)
      (if (not (ldap-session-implicit-unbind-ok? session))
	  (raise (condition 
		  (&ldap-implicit-unbind (code #f) (session session))))
	  (if (ldap-session-auto-unbind? session)
	      (ldap-unbind session))))
  (remove-from-weak-table! *object-table* (ldap-session-c-pointer session))
  (ldap-session-free 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-to-weak-table! *object-table* 
			    (ldap-session-c-pointer session) 
			    session)
	(add-finalizer! session ldap-session-finalizer)
	(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 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-anonymous . 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))
		     (session #f) (code #f)))))

;;; 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
  (message) 
  "scsh_ldap_msgfree")

(define (ldap-message-unregister-object message)
  (ddisplay "UNREGISTER ldap-message " message)
  (remove-from-weak-table! *object-table*
			   (ldap-message-c-pointer message)))

(define (ldap-message-freeing-finalizer message)
  (ddisplay "FREE ldap-message " message)
  (ldap-message-unregister-object message)
  (ldap-msgfree 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)
	       (let ((pointer (ldap-message-c-pointer message)))
		 (ddisplay "ldap-search")
		 (or (lookup-in-weak-table *object-table* pointer)
		     (begin
		       (ddisplay "ldap-search new object " message)
		       (add-to-weak-table! *object-table* pointer message)
		       (set-ldap-message-session! message session)
		       (set-ldap-message-result! message #f)
		       (add-finalizer! message ldap-message-freeing-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-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 
			(code #f) (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 
			(code #f) (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)))
    (cond 
     ((ldap-first-message-internal session message)
      => (lambda (new-message)
	   (let ((pointer (ldap-message-c-pointer new-message)))
	     (or (lookup-in-weak-table *object-table* pointer)
		 (begin
		   (add-to-weak-table! *object-table* pointer new-message)
		   (set-ldap-message-session! new-message session)
		   (add-finalizer! new-message ldap-message-freeing-finalizer)
		   new-message)))))
     (else
      (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)))
    (cond
     ((ldap-next-message-internal session message)
      => (lambda (new-message)
	   (let ((pointer (ldap-message-c-pointer new-message)))
	     (or (lookup-in-weak-table *object-table* pointer)
		 (begin
		   (add-to-weak-table! *object-table* pointer new-message)
		   (set-ldap-message-session! new-message session)
		   (add-finalizer! new-message ldap-message-freeing-finalizer)
		   new-message)))))
     (else
      (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-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)
  (ddisplay "FREE ber-element " ber-element)
  (remove-from-weak-table! 
   *object-table* (ber-element-c-pointer 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 entry)))
     (lambda (attribute-name ber-element)
       (if attribute-name
	   (cond
	    ((lookup-in-weak-table *object-table* 
				   (ber-element-c-pointer ber-element))
	     => (lambda (be) 
		  (ddisplay "RE ber-element (ldap-first-attribute) " be)
		  (values attribute-name be)))
	    (else
	     (ddisplay "NEW ber-element (ldap-first-attribute) " ber-element)
	     (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 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 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 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 entry)
	(raise-ldap-condition 
	 (ldap-get-error-return-object session) session))))

(define (ldap-first-entry result . args)
  (let-optionals args ((session (current-ldap-session)))
    (cond 
     ((ldap-first-entry-internal session result)
      => (lambda (new-message)
	   (let ((pointer (ldap-message-c-pointer new-message)))
	     (cond
	      ((lookup-in-weak-table *object-table* pointer)
	       => (lambda (old-object)
		    (ddisplay "REUSE ldap-message as entry " old-object)
		    ;; nomitated in the category "hack of the year"
		    (set-ldap-message-result! old-object old-object)
		    old-object))
	      (else
	       ;; it's not certain that this code will ever be reached.
	       ;;
	       ;; don't add a finalizer in this case, because
	       ;; libldap will free the memory itself.
	       (ddisplay "NEW object (ldap-first-entry) result "
			 result " new-message " new-message)
	       (add-to-weak-table! *object-table* pointer new-message)
	       (set-ldap-message-session! new-message session)
	       (set-ldap-message-result! new-message result)
	       (add-finalizer! new-message ldap-message-unregister-object)
	       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 entry)
      => (lambda (new-message)
	   (let ((pointer (ldap-message-c-pointer new-message)))
	     (or (lookup-in-weak-table *object-table* pointer)
		 (begin
		   (ddisplay "NEW message (ldap-next-entry) " new-message 
			     " parent " (ldap-message-result entry))
		   ;; don't add a finalizer in this case, because
		   ;; libldap will free the memory itself.
		   (add-to-weak-table! *object-table* pointer new-message)
		   (set-ldap-message-session! new-message session)
		   (set-ldap-message-result! new-message (ldap-message-result entry))
		   (add-finalizer! new-message ldap-message-unregister-object)
		   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")

;;; FIXME: maybe add type, memory handling
(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-freeing-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-freeing-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 ((ret-obj 
	   (convert-ldap-return-code 
	    (ldap-modify-internal session dn ldap-modifications))))
      (or (ldap-success? ret-obj)
	  (raise-ldap-condition ret-obj session)))))

;;;

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

(define (ldap-add dn ldap-modifications . args)
  (let-optionals args ((session (current-ldap-session)))
    (let ((ret-obj
	   (convert-ldap-return-code 
	    (ldap-add-internal session dn ldap-modifications))))
      (or (ldap-success? ret-obj)
	  (raise-ldap-condition ret-obj session)))))

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

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