scsh-conservatory
/
scsh-ldap
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The big "ldap-session as fluid"-surgery

This commit is contained in:
eknauel 2004-02-13 10:06:15 +00:00
parent 4e107b0a11
commit c015769f74
4 changed files with 241 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
etc/sample.scm
View File

@ -2,27 +2,30 @@
(define (open-anonymous-ldap-v3-session host)
(let ((session (ldap-init host)))
(set-ldap-session-option! session (ldap-session-option-value protocol-version) 3)
(set-ldap-session-option! (ldap-session-option-value protocol-version) 3 session)
(ldap-simple-bind-as-nobody session)
session))
(define (get-value-alist session entry)
(let ((attributes (ldap-all-attributes session entry)))
(define (get-value-alist entry)
(let ((attributes (ldap-all-attributes entry)))
(map (lambda (attribute)
(cons (string->symbol attribute)
(ldap-get-values session entry attribute)))
(ldap-get-values entry attribute)))
attributes)))
(define (find-all-entries host root-dn)
(let* ((session (open-anonymous-ldap-v3-session host))
(entry (ldap-search session root-dn (ldap-scope-arguments onelevel)
"(objectClass=*)"
ldap-attributes-all-user-attributes #f)))
(let lp ((entry (ldap-first-entry session entry))
(res '()))
(if (not entry)
res
(lp (ldap-next-entry session entry)
(cons (ldap-entry-dn session entry)
(cons (get-value-alist session entry) res)))))))
(with-ldap-session
(open-anonymous-ldap-v3-session host)
(lambda ()
(let ((first-entry
(ldap-search
root-dn (ldap-scope-arguments onelevel)
"(objectClass=*)" ldap-attributes-all-user-attributes #f)))
(let lp ((entry (ldap-first-entry first-entry))
(res '()))
(if (not entry)
res
(lp (ldap-next-entry entry)
(cons (ldap-entry-dn entry)
(cons (get-value-alist entry) res)))))))))

6
scheme/interfaces.scm
View File

@ -1,6 +1,7 @@
(define-interface ldap-low-interface
(define-interface ldap-interface
(export
ldap-init
with-ldap-session
ldap-simple-bind
ldap-simple-bind-as-nobody
ldap-sasl-bind
@ -100,6 +101,7 @@
(define-interface ldap-handle-types-interface
(export
ldap-session?
ldap-session=?
ldap-session-bound?
set-ldap-session-bound?!
ldap-session-options
@ -107,10 +109,12 @@
set-ldap-session-messages!
ldap-entry?
ldap-entry=?
make-ldap-entry
ldap-entry-message
ldap-message?
ldap-message=?
ldap-modification?
ldap-api-info?

385
scheme/ldap.scm
View File

@ -1,4 +1,12 @@
(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")
@ -37,19 +45,24 @@
(session user cred)
"scsh_ldap_simple_bind_s")
(define (ldap-simple-bind session user password)
(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 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-as-nobody session)
(ldap-simple-bind session #f #f))
(define (ldap-simple-bind-as-nobody . 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")
@ -66,12 +79,13 @@
(session)
"scsh_ldap_unbind_s")
(define (ldap-unbind 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))))
(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
@ -97,8 +111,10 @@
(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))
(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
@ -126,29 +142,31 @@
(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-option-value-id session-option) #t value)))
(lambda (call-successful? result)
(if call-successful?
result
(raise
(condition (&ldap-session-option-error (session session))))))))
(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 (session session)))))))))
(define (ldap-session-option session session-option)
(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 (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 (session session)))))))))
;;;
@ -158,8 +176,7 @@
(define (ldap-get-error-return-object session)
(convert-ldap-return-code
(ldap-session-option
session (ldap-session-option-value error-number))))
(ldap-session-option (ldap-session-option-value error-number) session)))
;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES
@ -167,31 +184,37 @@
(session message)
"scsh_ldap_first_message")
(define (ldap-first-message session message)
(or (ldap-first-message-internal session message)
(raise-ldap-condition
(ldap-get-error-return-object session) session)))
(define (ldap-first-message message . args)
(let-optionals args ((session (current-ldap-session)))
(or (ldap-first-message-internal session message)
(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 session message)
(or (ldap-next-message-internal session message)
(raise-ldap-condition
(ldap-get-error-return-object session) session)))
(define (ldap-next-message message . args)
(let-optionals args ((session (current-ldap-session)))
(or (ldap-next-message-internal session message)
(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 session message)
(let ((ret (ldap-count-messages-internal session message)))
(or ret
(raise-ldap-condition (ldap-get-error-return-object session) session))))
(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")
@ -209,9 +232,10 @@
(message)
"scsh_ldap_msgid")
(define (ldap-get-message-id session message)
(or (ldap-message-id-internal message)
(raise-ldap-condition (ldap-get-error-return-object session) session)))
(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))))
;;;
@ -230,36 +254,39 @@
(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 (ldap-entry-message entry))))
(lambda (attribute-name ber-element)
(if attribute-name
(begin
(add-finalizer! ber-element ber-element-finalizer)
(values attribute-name ber-element))
(raise-ldap-condition (ldap-get-error-return-object session) session)))))
(define (ldap-first-attribute entry . args)
(let-optionals args ((session (current-ldap-session)))
(call-with-values
(lambda ()
(apply values
(ldap-first-attribute-internal session (ldap-entry-message entry))))
(lambda (attribute-name ber-element)
(if attribute-name
(begin
(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 session entry ber-element)
(or (ldap-next-attribute-internal session (ldap-entry-message 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-next-attribute entry ber-element . args)
(let-optionals args ((session (current-ldap-session)))
(or (ldap-next-attribute-internal session (ldap-entry-message 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 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)))))
(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))))))
;;;
@ -267,14 +294,15 @@
(session entry attribute)
"scsh_ldap_get_values")
(define (ldap-get-values session entry attribute-name)
(let ((val (ldap-get-values-internal
session (ldap-entry-message 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))))))
(define (ldap-get-values entry attribute-name . args)
(let-optionals args ((session (current-ldap-session)))
(let ((val (ldap-get-values-internal
session (ldap-entry-message 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)))))))
;;;
@ -282,14 +310,15 @@
(session dn attribute value)
"scsh_ldap_compare_s")
(define (ldap-compare session dn attribute value)
(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))))
(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)))))
;;;
@ -297,9 +326,11 @@
(session message)
"scsh_ldap_get_dn")
(define (ldap-entry-dn session entry)
(or (ldap-get-dn-internal session (ldap-entry-message entry))
(raise-ldap-condition (ldap-get-error-return-object session) session)))
(define (ldap-entry-dn entry . args)
(let-optionals args ((session (current-ldap-session)))
(or (ldap-get-dn-internal session (ldap-entry-message entry))
(raise-ldap-condition
(ldap-get-error-return-object session) session))))
;;;
@ -307,9 +338,11 @@
(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-condition (ldap-get-error-return-object session) session)))
(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))))
;;;
@ -317,9 +350,11 @@
(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-condition (ldap-get-error-return-object session dn no-types?))))
(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?)))))
;;;
@ -327,9 +362,11 @@
(dn)
"scsh_ldap_dn2ufn")
(define (ldap-make-dn-userfriendly session dn)
(or (ldap-dn2ufn-internal dn)
(raise-ldap-condition (ldap-get-error-return-object session) session)))
(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))))
;;;
@ -345,33 +382,37 @@
(session message)
"scsh_ldap_next_entry")
(define (ldap-count-entries session entry)
(or (ldap-count-entries-internal session (ldap-entry-message entry))
(raise-ldap-condition (ldap-get-error-return-object session) session)))
(define (ldap-count-entries entry . args)
(let-optionals args ((session (current-ldap-session)))
(or (ldap-count-entries-internal session (ldap-entry-message entry))
(raise-ldap-condition
(ldap-get-error-return-object session) session))))
(define (ldap-first-entry session entry)
(cond
((ldap-first-entry-internal session (ldap-entry-message entry))
=> (lambda (new-message)
(add-finalizer! new-message ldap-message-finalizer)
(make-ldap-entry 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-first-entry entry . args)
(let-optionals args ((session (current-ldap-session)))
(cond
((ldap-first-entry-internal session (ldap-entry-message entry))
=> (lambda (new-message)
(add-finalizer! new-message ldap-message-finalizer)
(make-ldap-entry 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 session entry)
(cond
((ldap-next-entry-internal session (ldap-entry-message entry))
=> (lambda (new-message)
(add-finalizer! new-message ldap-message-finalizer)
(make-ldap-entry 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 (ldap-entry-message entry))
=> (lambda (new-message)
(add-finalizer! new-message ldap-message-finalizer)
(make-ldap-entry new-message)))
(else
(let ((ret-obj (ldap-get-error-return-object session)))
(if (ldap-success? ret-obj)
#f
(raise-ldap-condition ret-obj session)))))))
;;;
@ -387,33 +428,36 @@
(session message)
"scsh_ldap_next_reference")
(define (ldap-count-references session message)
(or (ldap-count-references-internal session message)
(raise-ldap-condition (ldap-get-error-return-object session) session)))
(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 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-condition ret-obj 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-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 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-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-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)))))))
;;;
@ -421,14 +465,15 @@
(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)))))
(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))))))
;;;

4
scheme/packages.scm
View File

@ -1,9 +1,9 @@
(define-structure ldap-low ldap-low-interface
(define-structure ldap ldap-interface
(open scheme
define-record-types
primitives
external-calls
let-opt
fluids let-opt
srfi-13 srfi-34 srfi-35
ffi-tools-rts