diff --git a/scheme/conditions.scm b/scheme/conditions.scm index 6b20a2e..3004cc3 100644 --- a/scheme/conditions.scm +++ b/scheme/conditions.scm @@ -77,10 +77,10 @@ (define-condition-type &ldap-insufficient-access &ldap-security-error ldap-insufficient-access?) -(define-condition-type &ldap-busy &ldap-connection-error +(define-condition-type &ldap-busy &ldap-service-error ldap-busy?) -(define-condition-type &ldap-unavailable &ldap-connection-error +(define-condition-type &ldap-unavailable &ldap-service-error ldap-unavailable?) (define-condition-type &ldap-unwilling-to-perform &ldap-data-error @@ -89,9 +89,21 @@ (define-condition-type &ldap-loop-detect &ldap-error ldap-loop-detect?) +(define-condition-type &ldap-invalid-syntax &ldap-error + ldap-invalid-syntax?) + +(define-condition-type &ldap-invalid-dn-syntax &ldap-error + ldap-invalid-dn-syntax?) + (define-condition-type &ldap-naming-violation &ldap-data-error ldap-naming-violation?) +(define-condition-type &ldap-constraint-violation &ldap-data-error + ldap-constraint-violation?) + +(define-condition-type &ldap-type-or-value-exists &ldap-data-error + ldap-type-or-value-exists?) + (define-condition-type &ldap-objectclass-violation &ldap-data-error ldap-objectclass-violation?) @@ -104,6 +116,18 @@ (define-condition-type &ldap-already-exists &ldap-data-error ldap-already-exists?) +(define-condition-type &ldap-no-such-object &ldap-data-error + ldap-no-such-object?) + +(define-condition-type &ldap-alias-problem &ldap-data-error + ldap-alias-problem?) + +(define-condition-type &ldap-alias-deref-problem &ldap-data-error + ldap-alias-deref-problem?) + +(define-condition-type &ldap-referral-limit-exceeded &ldap-data-error + ldap-referral-limit-exceeded?) + (define-condition-type &ldap-no-objectclass-mods &ldap-data-error ldap-no-objectclass-mods?) @@ -154,59 +178,56 @@ (define raise-ldap-condition (let ((alist - (map - (lambda (p) (cons (ldap-return (car p)) (cadr p))) - '((operations-error &ldap-operations-error) - (protocol-error &ldap-protocol-error) - (timelimit-exceeded &ldap-timelimit-exceeded) - (sizelimit-exceeded &ldap-sizelimit-exceeded) - (strong-auth-not-supported &ldap-strong-auth-not-supported) - (strong-auth-required &ldap-strong-auth-required) - (adminlimit-exceeded &ldap-adminlimit-exceeded) - (unavailable-critical-extension &ldap-critical-extension-unavailable) - (confidentiality-required &ldap-confidentiality-required) - (sasl-bind-in-progress &ldap-sasl-bind-in-progress) - (no-such-attribute &ldap-no-such-attribute) - (undefined-type &ldap-undefined-type) - (inappropriate-type &ldap-inappropriate-type) - (constraint-violation &ldap-constaint-violation) - (type-or-value-exists &ldap-type-or-value-exists) - (invalid-syntax &ldap-invalid-syntax) - (no-such-object &ldap-no-such-object) - (alias-problem &ldap-alias-problem) - (invalid-dn-syntax &ldap-invalid-dn-syntax) - (is-leaf &ldap-is-leaf) - (alias-deref-problem &ldap-alias-deref-problem) - (inappropriate-auth &ldap-inappropriate-auth) - (invalid-credentials &ldap-invalid-credentials) - (insufficient-access &ldap-insufficient-access) - (busy &ldap-busy) - (unavailable &ldap-unavailable) - (unwilling-to-perform &ldap-unwilling-to-perform) - (loop-detect &ldap-loop-detect) - (naming-violation &ldap-naming-violation) - (object-class-violation &ldap-object-class-violation) - (not-allowed-on-leaf &ldap-not-allowed-on-leaf) - (not-allowed-on-rdn &ldap-not-allowed-on-rdn) - (already-exists &ldap-already-exists) - (no-object-class-mods &ldap-no-object-class-mods) - (results-too-large &ldap-results-too-large) - (affects-multiple-dsas &ldap-affects-multiple-dsas) - (other &ldap-other) - (server-down &ldap-server-down) - (local-error &ldap-local-error) - (encoding-error &ldap-encoding-error) - (decoding-error &ldap-decoding-error) - (timeout &ldap-timeout) - (auth-unknown &ldap-auth-unknown) - (filter-error &ldap-filter-error) - (user-cancelled &ldap-user-cancelled) - (param-error &ldap-param-error) - (no-memory &ldap-no-memory) - (connect-error &ldap-connect-error) - (not-supported &ldap-not-supported) - (control-not-found &ldap-control-not-found) - (referral-limit-exceeded &ldap-referral-limit-execeeded))))) + `(((ldap-return operations-error) ,&ldap-operations-error) + ((ldap-return protocol-error) ,&ldap-protocol-error) + ((ldap-return timelimit-exceeded) ,&ldap-timelimit-exceeded) + ((ldap-return sizelimit-exceeded) ,&ldap-sizelimit-exceeded) + ((ldap-return strong-auth-not-supported) ,&ldap-strong-auth-not-supported) + ((ldap-return strong-auth-required) ,&ldap-strong-auth-required) + ((ldap-return adminlimit-exceeded) ,&ldap-adminlimit-exceeded) + ((ldap-return unavailable-critical-extension) ,&ldap-critical-extension-unavailable) + ((ldap-return confidentiality-required) ,&ldap-confidentiality-required) + ((ldap-return sasl-bind-in-progress) ,&ldap-sasl-bind-in-progress) + ((ldap-return no-such-attribute) ,&ldap-no-such-attribute) + ((ldap-return undefined-type) ,&ldap-undefined-type) + ((ldap-return inappropriate-type) ,&ldap-inappropriate-type) + ((ldap-return constraint-violation) ,&ldap-constraint-violation) + ((ldap-return type-or-value-exists) ,&ldap-type-or-value-exists) + ((ldap-return invalid-syntax) ,&ldap-invalid-syntax) + ((ldap-return no-such-object) ,&ldap-no-such-object) + ((ldap-return alias-problem) ,&ldap-alias-problem) + ((ldap-return invalid-dn-syntax) ,&ldap-invalid-dn-syntax) + ((ldap-return is-leaf) ,&ldap-not-allowed-on-leaf) + ((ldap-return alias-deref-problem) ,&ldap-alias-deref-problem) + ((ldap-return inappropriate-auth) ,&ldap-auth-unknown) + ((ldap-return invalid-credentials) ,&ldap-invalid-credentials) + ((ldap-return insufficient-access) ,&ldap-insufficient-access) + ((ldap-return busy) ,&ldap-busy) + ((ldap-return unavailable) ,&ldap-unavailable) + ((ldap-return unwilling-to-perform) ,&ldap-unwilling-to-perform) + ((ldap-return loop-detect) ,&ldap-loop-detect) + ((ldap-return naming-violation) ,&ldap-naming-violation) + ((ldap-return object-class-violation) ,&ldap-objectclass-violation) + ((ldap-return not-allowed-on-leaf) ,&ldap-not-allowed-on-leaf) + ((ldap-return not-allowed-on-rdn) ,&ldap-not-allowed-on-rdn) + ((ldap-return already-exists) ,&ldap-already-exists) + ((ldap-return no-object-class-mods) ,&ldap-no-objectclass-mods) + ((ldap-return results-too-large) ,&ldap-results-too-large) + ((ldap-return affects-multiple-dsas) ,&ldap-affects-multiple-dsas) + ((ldap-return other) ,&ldap-error) + ((ldap-return server-down) ,&ldap-server-down) + ((ldap-return local-error) ,&ldap-local-error) + ((ldap-return encoding-error) ,&ldap-encoding-error) + ((ldap-return decoding-error) ,&ldap-decoding-error) + ((ldap-return timeout) ,&ldap-timeout-error) + ((ldap-return auth-unknown) ,&ldap-auth-unknown) + ((ldap-return filter-error) ,&ldap-filter-error) + ((ldap-return param-error) ,&ldap-param-error) + ((ldap-return no-memory) ,&ldap-no-memory) + ((ldap-return connect-error) ,&ldap-connect-error) + ((ldap-return not-supported) ,&ldap-not-supported) + ((ldap-return control-not-found) ,&ldap-control-not-found) + ((ldap-return referral-limit-exceeded) ,&ldap-referral-limit-exceeded)))) (lambda (return-object session) (cond ((assoc return-object alist) @@ -217,9 +238,5 @@ (session session))))))) (else (raise - (condition (ldap-bindings-internal-error + (condition (&ldap-bindings-internal-error (code return-object))))))))) - - - - \ No newline at end of file diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index baaeee6..fd2bab0 100644 --- a/scheme/interfaces.scm +++ b/scheme/interfaces.scm @@ -7,27 +7,11 @@ ldap-error-string ldap-result-error)) -(define-interface ldap-types-interface - (export - ldap-session? - ldap-message? - ldap-modification? - - ldap-api-info? - ldap-api-info-info-version - ldap-api-info-api-version - ldap-api-info-protocol-version - ldap-api-info-vendor-name - ldap-api-info-vendor-version - - ldap-return-object? - ldap-return-elements)) - (define-interface ldap-conditions-interface (export &ldap-error ldap-error? ldap-error-code ldap-error-session &ldap-security-error ldap-security-error? - &ldap-connection-error ldap-connection-error? + &ldap-service-error ldap-service-error? &ldap-data-error ldap-data-error? &ldap-bindings-internal-error ldap-bindings-internal-error? @@ -52,11 +36,19 @@ &ldap-unavailable ldap-unavailable? &ldap-unwilling-to-perform ldap-unwilling-to-perform? &ldap-loop-detect ldap-loop-detect? + &ldap-invalid-syntax ldap-invalid-syntax? + &ldap-invalid-dn-syntax ldap-invalid-dn-syntax? &ldap-naming-violation ldap-naming-violation? + &ldap-constraint-violation ldap-constraint-violation? + &ldap-type-or-value-exists ldap-type-or-value-exists? &ldap-objectclass-violation ldap-objectclass-violation? &ldap-not-allowed-on-leaf ldap-not-allowed-on-leaf? &ldap-not-allowed-on-rdn ldap-not-allowed-on-rdn? &ldap-already-exists ldap-already-exists? + &ldap-no-such-object ldap-no-such-object? + &ldap-alias-problem ldap-alias-problem? + &ldap-alias-deref-problem ldap-alias-deref-problem? + &ldap-referral-limit-exceeded ldap-referral-limit-exceeded? &ldap-no-objectclass-mods ldap-no-objectclass-mods? &ldap-results-too-large ldap-results-too-large? &ldap-affects-multiple-dsas ldap-affects-multiple-dsas? @@ -73,3 +65,67 @@ &ldap-not-supported ldap-not-supported? &ldap-control-not-found ldap-control-not-found? &ldap-referral-limit-exceeded ldap-referral-limit-exceeded?)) + +(define-interface ldap-handle-types-interface + (export + ldap-session? + ldap-message? + ldap-modification? + + ldap-api-info? + ldap-api-info-info-version + ldap-api-info-api-version + ldap-api-info-protocol-version + ldap-api-info-vendor-name + ldap-api-info-vendor-version)) + +(define-interface ldap-return-interface + (export + ldap-return-object? + ldap-return-elements + ldap-return-name + (ldap-return :syntax))) + +(define-interface ldap-option-version-interface + (export + ldap-option-version-object? + ldap-option-version-elements + ldap-option-version-name + (ldap-option-version :syntax))) + +(define-interface ldap-scope-arguments-interface + (export + ldap-scope-arguments-object? + ldap-scope-arguments-elements + ldap-scope-arguments-name + (ldap-scope-arguments :syntax))) + +(define-interface ldap-session-option-values-interface + (export + ldap-session-option-value-object? + ldap-session-option-value-elements + ldap-session-option-value-name + (ldap-session-option-value :syntax))) + +(define-interface ldap-message-types-interface + (export + ldap-message-types-object? + ldap-message-types-elements + ldap-message-types-name + (ldap-message-types :syntax))) + +(define-interface ldap-attributes-special-values-interfaces + (export + ldap-attributes-no-attribute + ldap-attributes-all-user-attributes)) + +(define-interface ldap-types-interface + (compound-interface + ldap-return-interface + ldap-option-version-interface + ldap-scope-arguments-interface + ldap-session-option-values-interface + ldap-message-types-interface + ldap-attributes-special-values-interfaces + ;; + ldap-handle-types-interface)) diff --git a/scheme/ldap-constants.scm b/scheme/ldap-constants.scm index 9b74a41..c7bfb91 100644 --- a/scheme/ldap-constants.scm +++ b/scheme/ldap-constants.scm @@ -78,7 +78,7 @@ (map make-constant-from-c-name-integer '("LDAP_SCOPE_BASE" "LDAP_SCOPE_ONELEVEL" "LDAP_SCOPE_SUBTREE"))) - (define ldap-session-options + (define ldap-session-option-values (map make-constant-from-c-name-integer '("LDAP_OPT_API_INFO" "LDAP_OPT_DEREF" @@ -120,7 +120,7 @@ ldap-opt-protocol-version ldap-scope-arguments ldap-attribute-selectors - ldap-session-options + ldap-session-option-values ldap-message-types)) (define (write-source-file name string) @@ -164,8 +164,8 @@ ldap-scope-arguments) (generate-finite-type-definition - "ldap-session-options" (make-drop-common-prefix-name-converter "LDAP_OPT_") - ldap-session-options) + "ldap-session-option-value" (make-drop-common-prefix-name-converter "LDAP_OPT_") + ldap-session-option-values) (generate-finite-type-definition "ldap-message-types" (make-drop-common-prefix-name-converter "LDAP_RES_") diff --git a/scheme/ldap.scm b/scheme/ldap.scm index 0d20bcb..985112f 100644 --- a/scheme/ldap.scm +++ b/scheme/ldap.scm @@ -27,7 +27,7 @@ (set-ldap-session-options! session options) session))) -;;; +;;; SIMPLE_BIND_S (import-lambda-definition ldap-simple-bind-internal (session user cred) @@ -41,7 +41,7 @@ (set-ldap-session-bound?! session #t) (raise-ldap-error ret-obj session)))) -;;; +;;; SASL_BIND_S (import-lambda-definition ldap-sasl-bind-internal (session dn mechanism cred server-controls client-controls server-cred) @@ -53,7 +53,7 @@ (raise (condition (ldap-bindings-not-implemented (what '(ldap-sasl-bind ldap-controls)))))) -;;; +;;; UNBIND_S (import-lambda-definition ldap-unbind-internal (session) @@ -65,7 +65,7 @@ (set-ldap-session-bound?! ldap #f) (raise-ldap-error ret-obj session)))) -;;; +;;; SEARCH_S and SEARCH_ST (import-lambda-definition ldap-search-internal (session base scope filter attribute-list attributes-only?) @@ -111,7 +111,7 @@ message) (raise-ldap-error ret-obj session)))))))) -;;; +;;; GET/SET session options (import-lambda-definition ldap-get-set-option-internal (session option set? value) @@ -120,8 +120,9 @@ (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)) + (apply values + (ldap-get-set-option-internal + session (ldap-session-options-id session-option) #t value))) (lambda (call-successful? result) (if call-successful? result @@ -131,15 +132,16 @@ (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)) + (apply values + (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) @@ -150,7 +152,7 @@ (ldap-session-option session (ldap-session-option error-number)))) -;;; +;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES (import-lambda-definition ldap-first-message-internal (session message) @@ -177,7 +179,88 @@ (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)))) + (raise-ldap-error (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) (ldap-message-type code))) + (else + (raise-ldap-error (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-get-message-id-internal message) + (raise-ldap-error (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-error (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))))) + +(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-error (ldap-get-error-return-object session) session))) ;;; @@ -194,22 +277,94 @@ (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) +(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-error (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-error (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-error (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-error (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) +(import-lambda-definition ldap-first-entry-internal + (session message) "scsh_ldap_first_entry") -(import-lambda-definition ldap-next-entry-internal - (session message) +(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-error (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-error 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-error 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") @@ -218,37 +373,35 @@ (session message) "scsh_ldap_next_reference") -(import-lambda-definition ldap-count-references-internal - (session message) - "scsh_ldap_count_references") +(define (ldap-count-references session message) + (or (ldap-count-references-internal session message) + (raise-ldap-error (ldap-get-error-return-object session) session))) -(import-lambda-definition ldap-message-type-internal - (message) - "scsh_ldap_msgtype") +(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-error ret-obj session)))))) -(import-lambda-definition ldap-message-id-internal - (message) - "scsh_ldap_msgid") +(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-error ret-obj session)))))) -(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) diff --git a/scheme/packages.scm b/scheme/packages.scm index bb4a717..346bc49 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -9,11 +9,15 @@ (define-structure ldap-types ldap-types-interface (open scheme - define-record-types - external-calls) - (files types const-gen)) + define-record-types + external-calls + srfi-1 + finite-types + ffi-tools-rts) + (files const-gen types)) (define-structure ldap-conditions ldap-conditions-interface (open scheme - srfi-34 srfi-35) + srfi-34 srfi-35 + ldap-types) (files conditions)) diff --git a/scheme/types.scm b/scheme/types.scm index 841e7e8..9c6c90a 100644 --- a/scheme/types.scm +++ b/scheme/types.scm @@ -83,4 +83,4 @@ (define convert-ldap-message-type (make-finite-type-import-function - 'ldap-message-type ldap-message-type-elements ldap-message-type-id)) \ No newline at end of file + 'ldap-message-types ldap-message-types-elements ldap-message-types-id))