(declare
 (unit ldap)
 (uses lolevel)
 (foreign-declare "#include <ldap.h>"))

(define (ldap*:scope->int scope)
  (case scope
    ((one onelevel) (foreign-value "LDAP_SCOPE_ONELEVEL" int))
    ((sub subtree)  (foreign-value "LDAP_SCOPE_SUBTREE" int))
    ((base)         (foreign-value "LDAP_SCOPE_BASE" int))
    (else           (error "invalid scope" scope))))

(define (ldap*:int->scope scope-int)
  (cond
   ((eqv? scope-int (foreign-value "LDAP_SCOPE_ONELEVEL" int))    'onelevel)
   ((eqv? scope-int (foreign-value "LDAP_SCOPE_SUBTREE" int))     'subtree)
   ((eqv? scope-int (foreign-value "LDAP_SCOPE_BASE" int))        'base)
   (else  (error "invalid scope id" scope-int))))

(define-foreign-type scope int ldap*:scope->int ldap*:int->scope)

(define ldap:init
  (foreign-lambda c-pointer "ldap_init" nonnull-c-string int))
(define ldap:port (foreign-value "LDAP_PORT" int))

(define ldap:msg:free
  (foreign-lambda int "ldap_msgfree" c-pointer))

(define ldap:entry:count
  (foreign-lambda int "ldap_count_entries" nonnull-c-pointer nonnull-c-pointer))

(define ldap:entry:first
  (foreign-lambda c-pointer "ldap_first_entry" nonnull-c-pointer nonnull-c-pointer))

(define ldap:entry:next
  (foreign-lambda c-pointer "ldap_next_entry" nonnull-c-pointer nonnull-c-pointer))

(define ldap:unbind
  (foreign-lambda int "ldap_unbind" nonnull-c-pointer))

(define ldap:entry:dn
  (foreign-primitive ((nonnull-c-pointer ld)
		      (nonnull-c-pointer entry))
"C_word *ptr;
C_word dn;
char *c_dn;

c_dn = ldap_get_dn(ld, entry);
ptr = C_alloc(C_SIZEOF_STRING(strlen(c_dn)));
dn = C_string2(&ptr, c_dn);
ldap_memfree(c_dn);
C_values(3, C_SCHEME_UNDEFINED, C_k, dn);"))

(define ldap:entry->alist
  (letrec ((pointer->string*
	    (foreign-lambda* c-string ((c-pointer p)) "return(p);"))
	   (pointer->string
	    (lambda (p)
	      (and p
		   (let ((s (pointer->string* p)))
		     (mem-free p)
		     s))))
	   (first-attribute
	    (foreign-lambda c-pointer "ldap_first_attribute" nonnull-c-pointer nonnull-c-pointer nonnull-c-pointer))
	   (next-attribute
	    (foreign-lambda c-pointer "ldap_next_attribute" nonnull-c-pointer nonnull-c-pointer nonnull-c-pointer))
	   (mem-free
	    (foreign-lambda void "ldap_memfree" nonnull-c-pointer))
	   (get-values
	    (foreign-lambda c-pointer "ldap_get_values_len" nonnull-c-pointer nonnull-c-pointer nonnull-c-string))
	   (free-values
	    (foreign-lambda void "ldap_value_free_len" nonnull-c-pointer))
	   (ber-free
	    (foreign-lambda void "ber_free" nonnull-c-pointer int))
	   (berval-ref
	    (foreign-primitive ((nonnull-c-pointer berarray)
				(int n))
"C_word *aptr, outstr;
struct berval **ber = berarray;
if(ber[n])
  {
    aptr = C_alloc(C_SIZEOF_STRING(ber[n]->bv_len));
    outstr = C_string(&aptr, ber[n]->bv_len, ber[n]->bv_val);
    C_values(3, C_SCHEME_UNDEFINED, C_k, outstr);
  }
else
  {
    C_values(3, C_SCHEME_UNDEFINED, C_k, C_SCHEME_FALSE);
  }
")))			       
    (lambda (ld entry)
      (let-location ((ber-pointer c-pointer (null-pointer)))
	(let loop ((attrname (pointer->string (first-attribute ld entry (location ber-pointer))))
		   (attrlist '()))
	  (if attrname
	      (loop
	       (pointer->string (next-attribute ld entry ber-pointer))
	       (cons
		(cons
		 attrname
		 (let ((vals (get-values ld entry attrname)))
		   (let collect-values ((n 0)
					(l '()))
		     (let ((val (berval-ref vals n)))
		       (if val
			   (collect-values (+ n 1) (cons val l))
			   (begin
			     (free-values vals)
			     (reverse l)))))))
		attrlist))
	      (begin
		(ber-free ber-pointer 0)
		(reverse attrlist))))))))

(define ldap:search-s
  (foreign-primitive ((nonnull-c-pointer ld)
		      (nonnull-c-string base)
		      (scope scope)
		      (nonnull-c-string filter)
		      (scheme-object attrs)
		      (bool attrsonly))
"C_word *ptr;
LDAPMessage *c_res=NULL;
C_word res;
int r;
C_word item;
char **c_attrs;
int nattrs;
int i;
if (attrs == C_SCHEME_FALSE)
  {
    c_attrs = NULL;
  }
else
  {
    for(nattrs=0, item=attrs; item!=C_SCHEME_END_OF_LIST; ++nattrs, item=C_u_i_cdr(item))
      ;
    c_attrs=malloc(sizeof(char*)*(nattrs+1));
    c_attrs[nattrs] = NULL;
    for(i=0, item=attrs; item!=C_SCHEME_END_OF_LIST; ++i, item=C_u_i_cdr(item))
      {
        C_word attr = C_u_i_car(item);
        if(C_header_bits(attr) == C_STRING_TYPE)
          {
            int l=C_header_size(attr);
            c_attrs[i] = malloc(l + 1);
            c_attrs[i][l] = 0;
            memcpy(c_attrs[i], C_c_string(attr), l);
          }
        else
          exit(1); /* FIXME */
      }
  }
r = ldap_search_s(ld, base, scope, filter, c_attrs, attrsonly, &c_res);
if (c_attrs)
  {
    for(i=0; i<nattrs; ++i)
      free(c_attrs[i]);
    free(c_attrs);
  }
if (c_res)
  {
    ptr = C_alloc(C_SIZEOF_POINTER);
    res = C_mpointer(&ptr, c_res);
  }
else
  res = C_SCHEME_FALSE;
C_values(4, C_SCHEME_UNDEFINED, C_k, C_fix(r), res);"))


(define (ldap:simple-search-s ld base-dn scope filter attr-list attrs-only?)
  (receive (res msg) (ldap:search-s ld base-dn scope filter attr-list attrs-only?)
    (if msg
	(let loop ((entry (ldap:entry:first ld msg))
		   (result '()))
	  (if entry
	      (let ((dn (ldap:entry:dn ld entry))
		    (attrs (ldap:entry->alist ld entry)))
		(loop (ldap:entry:next ld entry)
		      (cons (cons dn attrs) result)))
	      (begin
		(ldap:msg:free msg)
		(reverse result))))
	#f)))