diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index fd2bab0..bf6d671 100644 --- a/scheme/interfaces.scm +++ b/scheme/interfaces.scm @@ -1,14 +1,44 @@ (define-interface ldap-low-interface (export - ldap-open ldap-init - ldap-bind-sync - ldap-unbind-sync - ldap-error-string - ldap-result-error)) + ldap-simple-bind + ldap-sasl-bind + ldap-unbind + ldap-search + set-ldap-session-option! + ldap-session-option + + ldap-first-message + ldap-next-message + ldap-count-messages + + ldap-get-message-type + ldap-get-message-id + + ldap-first-attribute + ldap-next-attribute + ldap-all-attributes + + ldap-get-values + ldap-compare + ldap-message-dn + ldap-explode-dn + ldap-explode-rdn + ldap-make-dn-userfriendly + + ldap-count-entries + ldap-first-entry + ldap-next-entry + + ldap-count-references + ldap-first-reference + ldap-next-reference)) + (define-interface ldap-conditions-interface (export + raise-ldap-condition + &ldap-error ldap-error? ldap-error-code ldap-error-session &ldap-security-error ldap-security-error? &ldap-service-error ldap-service-error? @@ -16,8 +46,8 @@ &ldap-bindings-internal-error ldap-bindings-internal-error? &ldap-bindings-not-implemented ldap-bindings-not-implemented? - &ldap-session-option-error ldap-session-option-error? &ldap-implicit-unbind ldap-implicit-unbind? + &ldap-session-option-error ldap-session-option-error? &ldap-operations-error ldap-operations-error? &ldap-protocol-error ldap-protocol-error? &ldap-timelimit-exceeded ldap-timelimit-exceeded? @@ -69,6 +99,11 @@ (define-interface ldap-handle-types-interface (export ldap-session? + ldap-session-bound? + set-ldap-session-bound?! + ldap-session-options + ldap-session-messages + ldap-message? ldap-modification? @@ -77,14 +112,24 @@ ldap-api-info-api-version ldap-api-info-protocol-version ldap-api-info-vendor-name - ldap-api-info-vendor-version)) + ldap-api-info-vendor-version + + make-session-options + set-ldap-session-options! + ldap-session-implicit-unbind-ok? + ldap-session-auto-unbind? + + ldap-session-messages-adjoin!)) (define-interface ldap-return-interface (export ldap-return-object? ldap-return-elements ldap-return-name - (ldap-return :syntax))) + (ldap-return :syntax) + convert-ldap-return-code + ldap-success?)) + (define-interface ldap-option-version-interface (export @@ -98,6 +143,7 @@ ldap-scope-arguments-object? ldap-scope-arguments-elements ldap-scope-arguments-name + ldap-scope-arguments-id (ldap-scope-arguments :syntax))) (define-interface ldap-session-option-values-interface @@ -105,6 +151,7 @@ ldap-session-option-value-object? ldap-session-option-value-elements ldap-session-option-value-name + ldap-session-option-value-id (ldap-session-option-value :syntax))) (define-interface ldap-message-types-interface @@ -112,7 +159,8 @@ ldap-message-types-object? ldap-message-types-elements ldap-message-types-name - (ldap-message-types :syntax))) + (ldap-message-types :syntax) + convert-ldap-message-type)) (define-interface ldap-attributes-special-values-interfaces (export diff --git a/scheme/ldap.scm b/scheme/ldap.scm index 985112f..7f29da5 100644 --- a/scheme/ldap.scm +++ b/scheme/ldap.scm @@ -1,4 +1,3 @@ -; ,open define-record-types external-calls (import-lambda-definition ldap-session-free (session) @@ -7,7 +6,7 @@ (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)))) + (raise (condition (&ldap-implicit-unbind (session session)))) (if (ldap-session-auto-unbind? session) (ldap-unbind session))))) @@ -35,11 +34,11 @@ (define (ldap-simple-bind session user password) (let ((ret-obj - (ldap-return + (convert-ldap-return-code (ldap-simple-bind-internal session user password)))) (if (ldap-success? ret-obj) (set-ldap-session-bound?! session #t) - (raise-ldap-error ret-obj session)))) + (raise-ldap-condition ret-obj session)))) ;;; SASL_BIND_S @@ -50,7 +49,7 @@ (define (ldap-sasl-bind session dn mechanism cred server-controls client-controls credentials) - (raise (condition (ldap-bindings-not-implemented + (raise (condition (&ldap-bindings-not-implemented (what '(ldap-sasl-bind ldap-controls)))))) ;;; UNBIND_S @@ -60,10 +59,11 @@ "scsh_ldap_unbind_s") (define (ldap-unbind session) - (let ((ret-obj (ldap-return (ldap-unbind-internal session)))) + (let ((ret-obj + (convert-ldap-return-code (ldap-unbind-internal session)))) (if (ldap-success? ret-obj) - (set-ldap-session-bound?! ldap #f) - (raise-ldap-error ret-obj session)))) + (set-ldap-session-bound?! session #f) + (raise-ldap-condition ret-obj session)))) ;;; SEARCH_S and SEARCH_ST @@ -91,7 +91,7 @@ (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)) + (let ((scope-id (ldap-scope-arguments-id scope)) (attr-list (ldap-attribute-list-kludge attribute-list))) (call-with-values (lambda () @@ -103,13 +103,14 @@ 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))) + (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-error ret-obj session)))))))) + (raise-ldap-condition ret-obj session)))))))) ;;; GET/SET session options @@ -122,7 +123,7 @@ (lambda () (apply values (ldap-get-set-option-internal - session (ldap-session-options-id session-option) #t value))) + session (ldap-session-option-value-id session-option) #t value))) (lambda (call-successful? result) (if call-successful? result @@ -134,7 +135,7 @@ (lambda () (apply values (ldap-get-set-option-internal - session (ldap-session-options-id session-option) #f #f))) + session (ldap-session-option-value-id session-option) #f #f))) (lambda (call-successful? result) (if call-successful? result @@ -148,9 +149,8 @@ "scsh_ldap_error_string") (define (ldap-get-error-return-object session) - (ldap-return - (ldap-session-option - session (ldap-session-option error-number)))) + (ldap-session-option session + (ldap-session-option-value error-number))) ;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES @@ -160,7 +160,7 @@ (define (ldap-first-message session message) (or (ldap-first-message-internal session message) - (raise-ldap-error + (raise-ldap-condition (ldap-get-error-return-object session) session))) (import-lambda-definition ldap-next-message-internal @@ -169,7 +169,7 @@ (define (ldap-next-message session message) (or (ldap-next-message-internal session message) - (raise-ldap-error + (raise-ldap-condition (ldap-get-error-return-object session) session))) (import-lambda-definition ldap-count-messages-internal @@ -179,7 +179,7 @@ (define (ldap-count-messages session message) (let ((ret (ldap-count-messages-internal session message))) (or ret - (raise-ldap-error (ldap-get-error-return-object session) session)))) + (raise-ldap-condition (ldap-get-error-return-object session) session)))) ;;; @@ -190,9 +190,9 @@ (define (ldap-get-message-type session message) (cond ((ldap-get-message-type-internal message) - => (lambda (code) (ldap-message-type code))) + => (lambda (code) (convert-ldap-message-type code))) (else - (raise-ldap-error (ldap-get-error-return-object session) session)))) + (raise-ldap-condition (ldap-get-error-return-object session) session)))) ;;; @@ -201,8 +201,8 @@ "scsh_ldap_msgid") (define (ldap-get-message-id session message) - (or (ldap-get-message-id-internal message) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (or (ldap-message-id-internal message) + (raise-ldap-condition (ldap-get-error-return-object session) session))) ;;; @@ -231,14 +231,14 @@ (begin (add-finalizer! ber-element ber-element-finalizer) (values attribute-name ber-element)) - (raise-ldap-error (ldap-get-error-return-object session) session))))) + (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-error ret-obj session))))) + (raise-ldap-condition ret-obj session))))) (define (ldap-all-attributes session entry) (call-with-values @@ -260,7 +260,7 @@ (define (ldap-get-values session entry attribute-name) (or (ldap-get-values-internal session entry attribute-name) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) ;;; @@ -270,12 +270,12 @@ (define (ldap-compare session dn attribute value) (let ((ret-obj - (ldap-return + (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-error ret-obj session)))) + (raise-ldap-condition ret-obj session)))) ;;; @@ -285,7 +285,7 @@ (define (ldap-message-dn session entry) (or (ldap-get-dn-internal session entry) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) ;;; @@ -295,7 +295,7 @@ (define (ldap-explode-dn session dn no-types?) (or (ldap-explode-dn-internal dn no-types?) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) ;;; @@ -305,7 +305,7 @@ (define (ldap-explode-rdn session dn no-types?) (or (ldap-explode-rdn-internal dn no-types?) - (raise-ldap-error (ldap-get-error-return-object session dn no-types?)))) + (raise-ldap-condition (ldap-get-error-return-object session dn no-types?)))) ;;; @@ -315,7 +315,7 @@ (define (ldap-make-dn-userfriendly session dn) (or (ldap-dn2ufn-internal dn) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) ;;; @@ -333,7 +333,7 @@ (define (ldap-count-entries session message) (or (ldap-count-entries-internal session message) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) (define (ldap-first-entry session message) (cond @@ -345,7 +345,7 @@ (let ((ret-obj (ldap-get-error-return-object session))) (if (ldap-success? ret-obj) #f - (raise-ldap-error ret-obj session)))))) + (raise-ldap-condition ret-obj session)))))) (define (ldap-next-entry session message) (cond @@ -357,7 +357,7 @@ (let ((ret-obj (ldap-get-error-return-object session))) (if (ldap-success? ret-obj) #f - (raise-ldap-error ret-obj session)))))) + (raise-ldap-condition ret-obj session)))))) ;;; @@ -375,7 +375,7 @@ (define (ldap-count-references session message) (or (ldap-count-references-internal session message) - (raise-ldap-error (ldap-get-error-return-object session) session))) + (raise-ldap-condition (ldap-get-error-return-object session) session))) (define (ldap-first-reference session message) (cond @@ -387,7 +387,7 @@ (let ((ret-obj (ldap-get-error-return-object session))) (if (ldap-success? ret-obj) #f - (raise-ldap-error ret-obj session)))))) + (raise-ldap-condition ret-obj session)))))) (define (ldap-next-reference session message) (cond @@ -399,7 +399,7 @@ (let ((ret-obj (ldap-get-error-return-object session))) (if (ldap-success? ret-obj) #f - (raise-ldap-error ret-obj session)))))) + (raise-ldap-condition ret-obj session)))))) ;;; @@ -407,6 +407,17 @@ (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") @@ -418,10 +429,4 @@ (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)) - diff --git a/scheme/packages.scm b/scheme/packages.scm index 346bc49..6e9218b 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -3,8 +3,12 @@ define-record-types primitives external-calls + let-opt srfi-34 srfi-35 - ffi-tools-rts) + ffi-tools-rts + + ldap-conditions + ldap-types) (files ldap)) (define-structure ldap-types ldap-types-interface