scsh-ldap/scheme/ldap.scm

; ,open define-record-types external-calls

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

;;;

(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 
	 (ldap-return
	  (ldap-simple-bind-internal session user password))))
    (if (ldap-success? ret-obj)
	(set-ldap-session-bound?! session #t)
	(raise-ldap-error ret-obj session))))

;;; 

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

;;;

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

(define (ldap-unbind session)
  (let ((ret-obj (ldap-return (ldap-unbind-internal session))))
    (if (ldap-success? ret-obj)
	(set-ldap-session-bound?! ldap #f)
	(raise-ldap-error ret-obj session))))

;;;

(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-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 (ldap-return ret-code)))
	   (if (ldap-success? ret-obj)
	       (begin
		 (ldap-session-messages-adjoin! session message)
		 (add-finalizer! message ldap-message-finalizer)
		 message)
	       (raise-ldap-error ret-obj session))))))))

;;;

(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 ()
     (ldap-get-set-option-internal 
      session (ldap-session-options-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 ()
     (ldap-get-set-option-internal
      session (ldap-session-options-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-return
   (ldap-session-option 
    session (ldap-session-option error-number))))

;;;

(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-error 
       (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-error
       (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-error (ldap-get-error-code 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 
	 (ldap-return 
	  (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-error ret-obj session))))

(import-lambda-definition ldap-result-error-internal 
  (session error-code) 
  "scsh_ldap_result")

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

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

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

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

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

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

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

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

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

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

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

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

;;; import functions from C
(define c-value->ldap-success
  (make-finite-type-import-function 
   'ldap-success ldap-success-elements ldap-success-id))