From e8d54a6390d2e0adbc8d24433e0fdcf6c363c33e Mon Sep 17 00:00:00 2001 From: eknauel Date: Thu, 8 Jan 2004 07:45:28 +0000 Subject: [PATCH] + error handling --- scheme/ldap.scm | 309 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 246 insertions(+), 63 deletions(-) diff --git a/scheme/ldap.scm b/scheme/ldap.scm index 385c9b4..0d20bcb 100644 --- a/scheme/ldap.scm +++ b/scheme/ldap.scm @@ -1,87 +1,270 @@ ; ,open define-record-types external-calls -(import-lambda-definition ldap-open-internal - (host port) - "scsh_ldap_open") +(import-lambda-definition ldap-session-free + (session) + "scsh_ldap_memfree") -(import-lambda-definition ldap-init-internal - (host port) - "scsh_ldap_init") +(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-bind - (ldap user password method) - "scsh_ldap_bind_s") +(import-lambda-definition ldap-init-internal + (host port) + "scsh_ldap_init") -(import-lambda-definition ldap-simple-bind - (ldap user password) - "scsh_ldap_simple_bind_s") +(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-kerberos-bind - (ldap dn) - "scsh_ldap_kerberos_bind_s") +;;; -(import-lambda-definition ldap-unbind - (ldap) - "scsh_ldap_unbind_s") +(import-lambda-definition ldap-simple-bind-internal + (session user cred) + "scsh_ldap_simple_bind_s") -(import-lambda-definition ldap-error-string - (error-code) - "scsh_ldap_error_string") +(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-result-error - (ldap result) - "scsh_ldap_result_error") +;;; -(import-lambda-definition ldap-memfree - (ldap) - "scsh_ldap_memfree") +(import-lambda-definition ldap-sasl-bind-internal + (session dn mechanism cred server-controls client-controls server-cred) + "scsh_ldap_sasl_bind_s") -(import-lambda-definition ldap-msgfree - (ldap) - "scsh_ldap_msgfree") +(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-search - (ldap base scope filter attributes attributes-only?) - "scsh_ldap_search_s") +;;; -(import-lambda-definition ldap-search-timeout - (ldap base scope filter attributes attributes-only? - timeout-secs timeout-usecs) - "scsh_ldap_search_st") +(import-lambda-definition ldap-unbind-internal + (session) + "scsh_ldap_unbind_s") -(import-lambda-definition ldap-count-entries - (ldap message) - "scsh_ldap_count_entries") +(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-first-entry - (ldap message) - "scsh_ldap_first_entry") +;;; -(import-lambda-definition ldap-next-entry - (ldap message) - "scsh_ldap_next_entry") +(import-lambda-definition ldap-search-internal + (session base scope filter attribute-list attributes-only?) + "scsh_ldap_search_s") -(import-lambda-definition ldap-message-type - (message) - "scsh_ldap_msgtype") +(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-message-id - (message) - "scsh_ldap_msgid") +(import-lambda-definition ldap-msgfree-internal + (message) + "scsh_ldap_msgfree") -(import-lambda-definition ldap-get-values - (ldap message attribute) - "scsh_ldap_get_values") +(define (ldap-message-finalizer message) + (ldap-msgfree-internal message)) -(define (ldap-open host port) - (let ((ldap (ldap-open-internal host port))) - (if ldap (add-finalizer! ldap ldap-memfree)) - ldap)) +(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-init host port) - (let ((ldap (ldap-init-internal host port))) - (if ldap (add-finalizer! ldap ldap-memfree)) - ldap)) +(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