The big "ldap-session as fluid"-surgery

etc/sample.scm

@@ -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)
+(define (get-value-alist entry)
-  (let ((attributes (ldap-all-attributes session 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))
+  (with-ldap-session
-	 (entry (ldap-search session root-dn (ldap-scope-arguments onelevel)
+   (open-anonymous-ldap-v3-session host)
-			     "(objectClass=*)"
+   (lambda ()
-			     ldap-attributes-all-user-attributes #f)))
+     (let ((first-entry 
-    (let lp ((entry (ldap-first-entry session 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 session entry)
+	     (lp (ldap-next-entry entry)
-	      (cons (ldap-entry-dn session entry)
+		 (cons (ldap-entry-dn entry)
-		    (cons (get-value-alist session entry) res)))))))
+		       (cons (get-value-alist entry) res)))))))))
    

scheme/interfaces.scm

@@ -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?

scheme/ldap.scm

@@ -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)
+(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))))
+	  (raise-ldap-condition ret-obj session)))))
 
-(define (ldap-simple-bind-as-nobody session)
+(define (ldap-simple-bind-as-nobody . args)
-  (ldap-simple-bind session #f #f))
+  (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)
+(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))))
+	  (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)
+(define (ldap-search base scope filter attribute-list attributes-only? . args)
-  (let-optionals args ((timeout-seconds #f) (timeout-microseconds #f))
+  (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,7 +142,8 @@
   (session option set? value)
   "scsh_ldap_get_set_option")
 
-(define (set-ldap-session-option! session session-option value)
+(define (set-ldap-session-option! session-option value . args)
+  (let-optionals args ((session (current-ldap-session)))
     (call-with-values
      (lambda ()
        (apply values
@@ -136,9 +153,10 @@
        (if call-successful?
 	   result
 	   (raise 
-	  (condition (&ldap-session-option-error (session session))))))))
+	    (condition (&ldap-session-option-error (session session)))))))))
 
-(define (ldap-session-option session session-option)
+(define (ldap-session-option session-option . args)
+  (let-optionals args ((session (current-ldap-session)))
     (call-with-values
      (lambda ()
        (apply values
@@ -148,7 +166,7 @@
        (if call-successful?
 	   result
 	   (raise
-	  (condition (&ldap-session-option-error (session session))))))))
+	    (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 
+   (ldap-session-option (ldap-session-option-value error-number) session)))
-    session (ldap-session-option-value error-number))))
 
 ;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES
 
@@ -167,31 +184,37 @@
   (session message) 
   "scsh_ldap_first_message")
 
-(define (ldap-first-message session message)
+(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)))
+	 (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)
+(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)))
+	 (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)
+(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))))
+	  (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)
+(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)))
+	(raise-ldap-condition (ldap-get-error-return-object session) session))))
 			     
 ;;;
 
@@ -230,7 +254,8 @@
 (define (ber-element-finalizer ber-element)
   (ber-element-free ber-element 1))
 
-(define (ldap-first-attribute session entry)
+(define (ldap-first-attribute entry . args)
+  (let-optionals args ((session (current-ldap-session)))
     (call-with-values
      (lambda ()
        (apply values
@@ -240,26 +265,28 @@
 	   (begin
 	     (add-finalizer! ber-element ber-element-finalizer)
 	     (values attribute-name ber-element))
-	 (raise-ldap-condition (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)
+(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)))))
+	      (raise-ldap-condition ret-obj session))))))
 
-(define (ldap-all-attributes session entry)
+(define (ldap-all-attributes entry . args)
+  (let-optionals args ((session (current-ldap-session)))
     (call-with-values
      (lambda ()
-     (ldap-first-attribute session entry))
+       (ldap-first-attribute entry session))
      (lambda (first-attribute ber-element)
-     (let loop ((next (ldap-next-attribute session entry ber-element))
+       (let loop ((next (ldap-next-attribute entry ber-element session))
 		  (attributes (list first-attribute)))
 	 (if next
-	   (loop (ldap-next-attribute session entry ber-element)
+	     (loop (ldap-next-attribute entry ber-element session)
 		   (cons next attributes))
-	   attributes)))))
+	     attributes))))))
 
 ;;;
 
@@ -267,14 +294,15 @@
   (session entry attribute)
   "scsh_ldap_get_values")
 
-(define (ldap-get-values session entry attribute-name)
+(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))))))
+		(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)
+(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))))
+	  (raise-ldap-condition ret-obj session)))))
 
 ;;;
 
@@ -297,9 +326,11 @@
   (session message)
   "scsh_ldap_get_dn")
 
-(define (ldap-entry-dn session entry)
+(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)))
+	(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?)
+(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)))
+	(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?)
+(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?))))
+	(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)
+(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)))
+	(raise-ldap-condition 
+	 (ldap-get-error-return-object session) session))))
 
 ;;;
 
@@ -345,11 +382,14 @@
   (session message)
   "scsh_ldap_next_entry")
 
-(define (ldap-count-entries session entry)
+(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)))
+	(raise-ldap-condition 
+	 (ldap-get-error-return-object session) session))))
 
-(define (ldap-first-entry session entry)
+(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)
@@ -359,9 +399,10 @@
       (let ((ret-obj (ldap-get-error-return-object session)))
 	(if (ldap-success? ret-obj)
 	    #f
-	  (raise-ldap-condition ret-obj session))))))
+	    (raise-ldap-condition ret-obj session)))))))
 
-(define (ldap-next-entry session entry)
+(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)
@@ -371,7 +412,7 @@
       (let ((ret-obj (ldap-get-error-return-object session)))
 	(if (ldap-success? ret-obj)
 	    #f
-	  (raise-ldap-condition ret-obj session))))))
+	    (raise-ldap-condition ret-obj session)))))))
 
 ;;;
 
@@ -387,11 +428,13 @@
   (session message)
   "scsh_ldap_next_reference")
 
-(define (ldap-count-references session message)
+(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)))
+	(raise-ldap-condition (ldap-get-error-return-object session) session))))
 
-(define (ldap-first-reference session message)
+(define (ldap-first-reference message . args)
+  (let-optionals args ((session (current-ldap-session)))
     (cond
      ((ldap-first-reference-internal session message)
       => (lambda (new-message)
@@ -401,9 +444,10 @@
       (let ((ret-obj (ldap-get-error-return-object session)))
 	(if (ldap-success? ret-obj)
 	    #f
-	  (raise-ldap-condition ret-obj session))))))
+	    (raise-ldap-condition ret-obj session)))))))
 
-(define (ldap-next-reference session message)
+(define (ldap-next-reference message . args)
+  (let-optionals args ((session (current-ldap-session)))
     (cond 
      ((ldap-next-reference-internal session message)
       => (lambda (new-message)
@@ -413,7 +457,7 @@
       (let ((ret-obj (ldap-get-error-return-object session)))
 	(if (ldap-success? ret-obj)
 	    #f
-	  (raise-ldap-condition ret-obj session))))))
+	    (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)
+(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)))))
+	    (raise-ldap-condition ret-obj session))))))
 
 ;;;
 

scheme/packages.scm

@@ -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