592 lines
19 KiB
Scheme
592 lines
19 KiB
Scheme
(define ddisplay
|
|
(lambda lst
|
|
(for-each
|
|
(lambda (x)
|
|
(cond
|
|
((ldap-message? x)
|
|
(display (number->string (ldap-message-c-pointer x) 16)))
|
|
((ber-element? x)
|
|
(display (number->string (ber-element-c-pointer x) 16)))
|
|
((ldap-session? x)
|
|
(display (number->string (ldap-session-c-pointer x) 16)))
|
|
(else
|
|
(display x))))
|
|
lst)
|
|
(newline)
|
|
(force-output (current-output-port))))
|
|
|
|
(define *object-table*
|
|
(make-value-weak-table))
|
|
|
|
(define $current-ldap-session (make-fluid #f))
|
|
|
|
(define (current-ldap-session)
|
|
(fluid $current-ldap-session))
|
|
|
|
(define (with-ldap-session session thunk)
|
|
(let-fluid $current-ldap-session session thunk))
|
|
|
|
(import-lambda-definition ldap-session-free
|
|
(session)
|
|
"scsh_ldap_memfree")
|
|
|
|
(define (ldap-session-finalizer session)
|
|
(ddisplay "FREE ldap-session " session)
|
|
(if (ldap-session-bound? session)
|
|
(if (not (ldap-session-implicit-unbind-ok? session))
|
|
(raise (condition
|
|
(&ldap-implicit-unbind (code #f) (session session))))
|
|
(if (ldap-session-auto-unbind? session)
|
|
(ldap-unbind session))))
|
|
(remove-from-weak-table! *object-table* (ldap-session-c-pointer session))
|
|
(ldap-session-free session))
|
|
|
|
(import-lambda-definition ldap-init-internal
|
|
(host port)
|
|
"scsh_ldap_init")
|
|
|
|
(define (ldap-init host-name-or-list . args)
|
|
(let-optionals args
|
|
((port 0) ; use default port
|
|
(implicit-unbind-ok? #f)
|
|
(unbind-automatically? #t))
|
|
(let ((hosts (if (list? host-name-or-list)
|
|
(string-join host-name-or-list)
|
|
host-name-or-list)))
|
|
(let ((session (ldap-init-internal hosts port))
|
|
(options (make-session-options implicit-unbind-ok?
|
|
unbind-automatically?)))
|
|
(add-to-weak-table! *object-table*
|
|
(ldap-session-c-pointer session)
|
|
session)
|
|
(add-finalizer! session ldap-session-finalizer)
|
|
(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 user password . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(let ((ret-obj
|
|
(convert-ldap-return-code
|
|
(ldap-simple-bind-internal session user password))))
|
|
(if (ldap-success? ret-obj)
|
|
(set-ldap-session-bound?! session #t)
|
|
(raise-ldap-condition ret-obj session)))))
|
|
|
|
(define (ldap-simple-bind-anonymous . args)
|
|
(let-optionals args ((session . (current-ldap-session)))
|
|
(ldap-simple-bind #f #f session)))
|
|
|
|
;;; SASL_BIND_S
|
|
|
|
;;; FIXME: Need interface to BER-elements before this functions is
|
|
;;; usable
|
|
|
|
(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))
|
|
(session #f) (code #f)))))
|
|
|
|
;;; UNBIND_S
|
|
|
|
(import-lambda-definition ldap-unbind-internal
|
|
(session)
|
|
"scsh_ldap_unbind_s")
|
|
|
|
(define (ldap-unbind . args)
|
|
(let-optionals args ((session . (current-ldap-session)))
|
|
(let ((ret-obj
|
|
(convert-ldap-return-code (ldap-unbind-internal session))))
|
|
(if (ldap-success? ret-obj)
|
|
(set-ldap-session-bound?! session #f)
|
|
(raise-ldap-condition 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
|
|
(message)
|
|
"scsh_ldap_msgfree")
|
|
|
|
(define (ldap-message-unregister-object message)
|
|
(ddisplay "UNREGISTER ldap-message " message)
|
|
(remove-from-weak-table! *object-table*
|
|
(ldap-message-c-pointer message)))
|
|
|
|
(define (ldap-message-freeing-finalizer message)
|
|
(ddisplay "FREE ldap-message " message)
|
|
(ldap-message-unregister-object message)
|
|
(ldap-msgfree 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 base scope filter attribute-list attributes-only? . args)
|
|
(let-optionals args ((session (current-ldap-session))
|
|
(timeout-seconds #f)
|
|
(timeout-microseconds #f))
|
|
(let ((scope-id (ldap-scope-arguments-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-id filter attr-list attributes-only?)
|
|
(ldap-search-with-timeout-internal
|
|
session base scope-id filter attr-list attributes-only?
|
|
timeout-seconds (or timeout-microseconds 0)))))
|
|
(lambda (ret-code message)
|
|
(let ((ret-obj
|
|
(convert-ldap-return-code ret-code)))
|
|
(if (ldap-success? ret-obj)
|
|
(let ((pointer (ldap-message-c-pointer message)))
|
|
(ddisplay "ldap-search")
|
|
(or (lookup-in-weak-table *object-table* pointer)
|
|
(begin
|
|
(ddisplay "ldap-search new object " message)
|
|
(add-to-weak-table! *object-table* pointer message)
|
|
(set-ldap-message-session! message session)
|
|
(set-ldap-message-result! message #f)
|
|
(add-finalizer! message ldap-message-freeing-finalizer)
|
|
message)))
|
|
(raise-ldap-condition 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-option value . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(ldap-get-set-option-internal
|
|
session (ldap-session-option-value-id session-option) #t value)))
|
|
(lambda (call-successful? result)
|
|
(if call-successful?
|
|
result
|
|
(raise
|
|
(condition (&ldap-session-option-error
|
|
(code #f) (session session)))))))))
|
|
|
|
(define (ldap-session-option session-option . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(ldap-get-set-option-internal
|
|
session (ldap-session-option-value-id session-option) #f #f)))
|
|
(lambda (call-successful? result)
|
|
(if call-successful?
|
|
result
|
|
(raise
|
|
(condition (&ldap-session-option-error
|
|
(code #f) (session session)))))))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-error-string-internal
|
|
(session error-code)
|
|
"scsh_ldap_error_string")
|
|
|
|
(define (ldap-get-error-return-object session)
|
|
(convert-ldap-return-code
|
|
(ldap-session-option (ldap-session-option-value error-number) session)))
|
|
|
|
;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES
|
|
|
|
(import-lambda-definition ldap-first-message-internal
|
|
(session message)
|
|
"scsh_ldap_first_message")
|
|
|
|
(define (ldap-first-message message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-first-message-internal session message)
|
|
=> (lambda (new-message)
|
|
(let ((pointer (ldap-message-c-pointer new-message)))
|
|
(or (lookup-in-weak-table *object-table* pointer)
|
|
(begin
|
|
(add-to-weak-table! *object-table* pointer new-message)
|
|
(set-ldap-message-session! new-message session)
|
|
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
|
new-message)))))
|
|
(else
|
|
(raise-ldap-condition
|
|
(ldap-get-error-return-object session) session)))))
|
|
|
|
(import-lambda-definition ldap-next-message-internal
|
|
(session message)
|
|
"scsh_ldap_next_message")
|
|
|
|
(define (ldap-next-message message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-next-message-internal session message)
|
|
=> (lambda (new-message)
|
|
(let ((pointer (ldap-message-c-pointer new-message)))
|
|
(or (lookup-in-weak-table *object-table* pointer)
|
|
(begin
|
|
(add-to-weak-table! *object-table* pointer new-message)
|
|
(set-ldap-message-session! new-message session)
|
|
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
|
new-message)))))
|
|
(else
|
|
(raise-ldap-condition
|
|
(ldap-get-error-return-object session) session)))))
|
|
|
|
(import-lambda-definition ldap-count-messages-internal
|
|
(session message)
|
|
"scsh_ldap_count_messages")
|
|
|
|
(define (ldap-count-messages message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(let ((ret (ldap-count-messages-internal session message)))
|
|
(or ret
|
|
(raise-ldap-condition (ldap-get-error-return-object session) session)))))
|
|
|
|
;;;
|
|
|
|
;;; FIXME: Do we need this function if we introduce types for the
|
|
;;; diffrent ldap-messages?
|
|
|
|
(import-lambda-definition ldap-get-message-type-internal
|
|
(message)
|
|
"scsh_ldap_msgtype")
|
|
|
|
(define (ldap-message-type session message)
|
|
(cond
|
|
((ldap-get-message-type-internal message)
|
|
=> (lambda (code) (convert-ldap-message-type code)))
|
|
(else
|
|
(raise-ldap-condition (ldap-get-error-return-object session) session))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-message-id-internal
|
|
(message)
|
|
"scsh_ldap_msgid")
|
|
|
|
(define (ldap-get-message-id message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-message-id-internal message)
|
|
(raise-ldap-condition (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)
|
|
(ddisplay "FREE ber-element " ber-element)
|
|
(remove-from-weak-table!
|
|
*object-table* (ber-element-c-pointer ber-element))
|
|
(ber-element-free ber-element 1))
|
|
|
|
(define (ldap-first-attribute entry . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(ldap-first-attribute-internal session entry)))
|
|
(lambda (attribute-name ber-element)
|
|
(if attribute-name
|
|
(cond
|
|
((lookup-in-weak-table *object-table*
|
|
(ber-element-c-pointer ber-element))
|
|
=> (lambda (be)
|
|
(ddisplay "RE ber-element (ldap-first-attribute) " be)
|
|
(values attribute-name be)))
|
|
(else
|
|
(ddisplay "NEW ber-element (ldap-first-attribute) " ber-element)
|
|
(add-finalizer! ber-element ber-element-finalizer)
|
|
(values attribute-name ber-element)))
|
|
(raise-ldap-condition
|
|
(ldap-get-error-return-object session) session))))))
|
|
|
|
(define (ldap-next-attribute entry ber-element . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(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-condition ret-obj session))))))
|
|
|
|
(define (ldap-all-attributes entry . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(ldap-first-attribute entry session))
|
|
(lambda (first-attribute ber-element)
|
|
(let loop ((next (ldap-next-attribute entry ber-element session))
|
|
(attributes (list first-attribute)))
|
|
(if next
|
|
(loop (ldap-next-attribute entry ber-element session)
|
|
(cons next attributes))
|
|
attributes))))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-get-values-internal
|
|
(session entry attribute)
|
|
"scsh_ldap_get_values")
|
|
|
|
(define (ldap-get-values entry attribute-name . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(let ((val (ldap-get-values-internal
|
|
session entry attribute-name)))
|
|
(or val
|
|
(let ((ret-obj (ldap-get-error-return-object session)))
|
|
(if (ldap-success? ret-obj)
|
|
val
|
|
(raise-ldap-condition ret-obj session)))))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-compare-internal
|
|
(session dn attribute value)
|
|
"scsh_ldap_compare_s")
|
|
|
|
(define (ldap-compare dn attribute value . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(let ((ret-obj
|
|
(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-condition ret-obj session)))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-get-dn-internal
|
|
(session message)
|
|
"scsh_ldap_get_dn")
|
|
|
|
(define (ldap-entry-dn entry . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-get-dn-internal session entry)
|
|
(raise-ldap-condition
|
|
(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 dn no-types? . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-explode-dn-internal dn no-types?)
|
|
(raise-ldap-condition
|
|
(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 dn no-types? . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-explode-rdn-internal dn no-types?)
|
|
(raise-ldap-condition
|
|
(ldap-get-error-return-object session dn no-types?)))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-dn2ufn-internal
|
|
(dn)
|
|
"scsh_ldap_dn2ufn")
|
|
|
|
(define (ldap-make-dn-userfriendly dn . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-dn2ufn-internal dn)
|
|
(raise-ldap-condition
|
|
(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 entry . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-count-entries-internal session entry)
|
|
(raise-ldap-condition
|
|
(ldap-get-error-return-object session) session))))
|
|
|
|
(define (ldap-first-entry result . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-first-entry-internal session result)
|
|
=> (lambda (new-message)
|
|
(let ((pointer (ldap-message-c-pointer new-message)))
|
|
(cond
|
|
((lookup-in-weak-table *object-table* pointer)
|
|
=> (lambda (old-object)
|
|
(ddisplay "REUSE ldap-message as entry " old-object)
|
|
;; nomitated in the category "hack of the year"
|
|
(set-ldap-message-result! old-object old-object)
|
|
old-object))
|
|
(else
|
|
;; it's not certain that this code will ever be reached.
|
|
;;
|
|
;; don't add a finalizer in this case, because
|
|
;; libldap will free the memory itself.
|
|
(ddisplay "NEW object (ldap-first-entry) result "
|
|
result " new-message " new-message)
|
|
(add-to-weak-table! *object-table* pointer new-message)
|
|
(set-ldap-message-session! new-message session)
|
|
(set-ldap-message-result! new-message result)
|
|
(add-finalizer! new-message ldap-message-unregister-object)
|
|
new-message))))
|
|
(else
|
|
(let ((ret-obj (ldap-get-error-return-object session)))
|
|
(if (ldap-success? ret-obj)
|
|
#f
|
|
(raise-ldap-condition ret-obj session))))))))
|
|
|
|
(define (ldap-next-entry entry . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-next-entry-internal session entry)
|
|
=> (lambda (new-message)
|
|
(let ((pointer (ldap-message-c-pointer new-message)))
|
|
(or (lookup-in-weak-table *object-table* pointer)
|
|
(begin
|
|
(ddisplay "NEW message (ldap-next-entry) " new-message
|
|
" parent " (ldap-message-result entry))
|
|
;; don't add a finalizer in this case, because
|
|
;; libldap will free the memory itself.
|
|
(add-to-weak-table! *object-table* pointer new-message)
|
|
(set-ldap-message-session! new-message session)
|
|
(set-ldap-message-result! new-message (ldap-message-result entry))
|
|
(add-finalizer! new-message ldap-message-unregister-object)
|
|
new-message)))))
|
|
(else
|
|
(let ((ret-obj (ldap-get-error-return-object session)))
|
|
(if (ldap-success? ret-obj)
|
|
#f
|
|
(raise-ldap-condition 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")
|
|
|
|
;;; FIXME: maybe add type, memory handling
|
|
(define (ldap-count-references message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(or (ldap-count-references-internal session message)
|
|
(raise-ldap-condition (ldap-get-error-return-object session) session))))
|
|
|
|
(define (ldap-first-reference message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-first-reference-internal session message)
|
|
=> (lambda (new-message)
|
|
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
|
new-message))
|
|
(else
|
|
(let ((ret-obj (ldap-get-error-return-object session)))
|
|
(if (ldap-success? ret-obj)
|
|
#f
|
|
(raise-ldap-condition ret-obj session)))))))
|
|
|
|
(define (ldap-next-reference message . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(cond
|
|
((ldap-next-reference-internal session message)
|
|
=> (lambda (new-message)
|
|
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
|
new-message))
|
|
(else
|
|
(let ((ret-obj (ldap-get-error-return-object session)))
|
|
(if (ldap-success? ret-obj)
|
|
#f
|
|
(raise-ldap-condition ret-obj session)))))))
|
|
|
|
;;;
|
|
|
|
(import-lambda-definition ldap-modify-internal
|
|
(session dn ldap-modification-vector)
|
|
"scsh_ldap_modify")
|
|
|
|
(define (ldap-modify dn ldap-modifications . args)
|
|
(let-optionals args ((session (current-ldap-session)))
|
|
(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")
|
|
|
|
(import-lambda-definition ldap-delete-internal
|
|
(session dn)
|
|
"scsh_ldap_delete")
|
|
|
|
(import-lambda-definition ldap-abandon-internal
|
|
(session message-id)
|
|
"scsh_ldap_abandon")
|