428 lines
12 KiB
Scheme
428 lines
12 KiB
Scheme
; ,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)))
|
|
|
|
;;; SIMPLE_BIND_S
|
|
|
|
(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))))
|
|
|
|
;;; SASL_BIND_S
|
|
|
|
(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))))))
|
|
|
|
;;; UNBIND_S
|
|
|
|
(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))))
|
|
|
|
;;; 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-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))))))))
|
|
|
|
;;; 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 session-option value)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(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 ()
|
|
(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)
|
|
"scsh_ldap_error_string")
|
|
|
|
(define (ldap-get-error-return-object session)
|
|
(ldap-return
|
|
(ldap-session-option
|
|
session (ldap-session-option error-number))))
|
|
|
|
;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES
|
|
|
|
(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-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)))
|
|
|
|
;;;
|
|
|
|
(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-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)
|
|
"scsh_ldap_first_entry")
|
|
|
|
(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")
|
|
|
|
(import-lambda-definition ldap-next-reference-internal
|
|
(session message)
|
|
"scsh_ldap_next_reference")
|
|
|
|
(define (ldap-count-references session message)
|
|
(or (ldap-count-references-internal session message)
|
|
(raise-ldap-error (ldap-get-error-return-object session) session)))
|
|
|
|
(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))))))
|
|
|
|
(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-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))
|
|
|
|
|