git.chise.org Git - chise/xemacs-chise.git.1/blob - src/eldap.c

   1 /* LDAP client interface for XEmacs.
   2    Copyright (C) 1998 Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Not in FSF. */
  22
  23 /* Author: Oscar Figueiredo with lots of support from Hrvoje Niksic */
  24
  25 /* This file provides lisp primitives for access to an LDAP library
  26    conforming to the API defined in RFC 1823.
  27    It has been tested with:
  28    - UMich LDAP 3.3 (http://www.umich.edu/~dirsvcs/ldap/)
  29    - OpenLDAP 1.2 (http://www.openldap.org/)
  30    - Netscape's LDAP SDK (http://developer.netscape.com/) */
  31
  32
  33 #include <config.h>
  34 #include "lisp.h"
  35 #include "opaque.h"
  36 #include "sysdep.h"
  37 #include "buffer.h"
  38
  39 #include <errno.h>
  40
  41 #include "eldap.h"
  42
  43 static int ldap_default_port;
  44 static Lisp_Object Vldap_default_base;
  45
  46 /* Needed by the lrecord definition */
  47 Lisp_Object Qldapp;
  48
  49 /* ldap-open plist keywords */
  50 extern Lisp_Object Qport, Qauth, Qbinddn, Qpasswd, Qderef, Qtimelimit,
  51   Qsizelimit;
  52 /* Search scope limits */
  53 extern Lisp_Object Qbase, Qonelevel, Qsubtree;
  54 /* Authentication methods */
  55 extern Lisp_Object Qkrbv41, Qkrbv42;
  56 /* Deref policy */
  57 extern Lisp_Object Qnever, Qalways, Qfind;
  58 \f
  59 /************************************************************************/
  60 /*                         Utility Functions                            */
  61 /************************************************************************/
  62
  63 static void
  64 signal_ldap_error (LDAP *ld, LDAPMessage *res, int ldap_err)
  65 {
  66   if (ldap_err <= 0)
  67     {
  68 #if defined HAVE_LDAP_PARSE_RESULT
  69       int err;
  70       ldap_err = ldap_parse_result (ld, res,
  71                                     &err,
  72                                     NULL, NULL, NULL, NULL, 0);
  73       if (ldap_err == LDAP_SUCCESS)
  74         ldap_err = err;
  75 #elif defined HAVE_LDAP_GET_LDERRNO
  76       ldap_err = ldap_get_lderrno (ld, NULL, NULL);
  77 #elif defined HAVE_LDAP_RESULT2ERROR
  78       ldap_err = ldap_result2error (ld, res, 0);
  79 #else
  80       ldap_err = ld->ld_errno;
  81 #endif
  82     }
  83   signal_simple_error ("LDAP error",
  84                        build_string (ldap_err2string (ldap_err)));
  85 }
  86
  87 \f
  88 /************************************************************************/
  89 /*                        ldap lrecord basic functions                  */
  90 /************************************************************************/
  91
  92 static Lisp_Object
  93 make_ldap (struct Lisp_LDAP *ldap)
  94 {
  95   Lisp_Object lisp_ldap;
  96   XSETLDAP (lisp_ldap, ldap);
  97   return lisp_ldap;
  98 }
  99
 100 static Lisp_Object
 101 mark_ldap (Lisp_Object obj, void (*markobj) (Lisp_Object))
 102 {
 103   return XLDAP (obj)->host;
 104 }
 105
 106 static void
 107 print_ldap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 108 {
 109   char buf[32];
 110
 111   struct Lisp_LDAP *ldap = XLDAP (obj);
 112
 113   if (print_readably)
 114     error ("printing unreadable object #<ldap %s>",
 115            XSTRING_DATA (ldap->host));
 116
 117   write_c_string ("#<ldap ", printcharfun);
 118   print_internal (ldap->host, printcharfun, 1);
 119   if (!ldap->ld)
 120     write_c_string ("(dead) ",printcharfun);
 121   sprintf (buf, " 0x%x>", (unsigned int)ldap);
 122   write_c_string (buf, printcharfun);
 123 }
 124
 125 static struct Lisp_LDAP *
 126 allocate_ldap (void)
 127 {
 128   struct Lisp_LDAP *ldap =
 129     alloc_lcrecord_type (struct Lisp_LDAP, &lrecord_ldap);
 130
 131   ldap->ld = NULL;
 132   ldap->host = Qnil;
 133   return ldap;
 134 }
 135
 136 static void
 137 finalize_ldap (void *header, int for_disksave)
 138 {
 139   struct Lisp_LDAP *ldap = (struct Lisp_LDAP *) header;
 140
 141   if (for_disksave)
 142     signal_simple_error ("Can't dump an emacs containing LDAP objects",
 143                          make_ldap (ldap));
 144
 145   if (ldap->ld)
 146     ldap_unbind (ldap->ld);
 147   ldap->ld = NULL;
 148 }
 149
 150 DEFINE_LRECORD_IMPLEMENTATION ("ldap", ldap,
 151                                mark_ldap, print_ldap, finalize_ldap,
 152                                NULL, NULL, 0, struct Lisp_LDAP);
 153
 154
 155
 156 \f
 157 /************************************************************************/
 158 /*                        Basic ldap accessors                          */
 159 /************************************************************************/
 160
 161 DEFUN ("ldapp", Fldapp, 1, 1, 0, /*
 162 Return t if OBJECT is a LDAP connection.
 163 */
 164        (object))
 165 {
 166   return LDAPP (object) ? Qt : Qnil;
 167 }
 168
 169 DEFUN ("ldap-host", Fldap_host, 1, 1, 0, /*
 170 Return the server host of the connection LDAP, as a string.
 171 */
 172        (ldap))
 173 {
 174   CHECK_LDAP (ldap);
 175   return (XLDAP (ldap))->host;
 176 }
 177
 178 DEFUN ("ldap-live-p", Fldap_status, 1, 1, 0, /*
 179 Return t if LDAP is an active LDAP connection.
 180 */
 181        (ldap))
 182 {
 183   CHECK_LDAP (ldap);
 184   return (XLDAP (ldap))->ld ? Qt : Qnil;
 185 }
 186 \f
 187 /************************************************************************/
 188 /*                  Opening/Closing a LDAP connection                   */
 189 /************************************************************************/
 190
 191
 192 DEFUN ("ldap-open", Fldap_open, 1, 2, 0, /*
 193 Open a LDAP connection to HOST.
 194 PLIST is a plist containing additional parameters for the connection.
 195 Valid keys in that list are:
 196   `port' the TCP port to use for the connection if different from
 197 `ldap-default-port'.
 198   `auth' is the authentication method to use, possible values depend on
 199 the LDAP library XEmacs was compiled with: `simple', `krbv41' and `krbv42'.
 200   `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax).
 201   `passwd' is the password to use for simple authentication.
 202   `deref' is one of the symbols `never', `always', `search' or `find'.
 203   `timelimit' is the timeout limit for the connection in seconds.
 204   `sizelimit' is the maximum number of matches to return.
 205 */
 206        (host, plist))
 207 {
 208   /* This function can GC */
 209   struct Lisp_LDAP *ldap;
 210   LDAP *ld;
 211   int  ldap_port = 0;
 212   int  ldap_auth = LDAP_AUTH_SIMPLE;
 213   char *ldap_binddn = NULL;
 214   char *ldap_passwd = NULL;
 215   int  ldap_deref = LDAP_DEREF_NEVER;
 216   int  ldap_timelimit = 0;
 217   int  ldap_sizelimit = 0;
 218   int  err;
 219
 220   Lisp_Object list, keyword, value;
 221
 222   CHECK_STRING (host);
 223
 224   EXTERNAL_PROPERTY_LIST_LOOP (list, keyword, value, plist)
 225     {
 226       /* TCP Port */
 227       if (EQ (keyword, Qport))
 228         {
 229           CHECK_INT (value);
 230           ldap_port = XINT (value);
 231         }
 232       /* Authentication method */
 233       if (EQ (keyword, Qauth))
 234         {
 235           if (EQ (value, Qsimple))
 236             ldap_auth = LDAP_AUTH_SIMPLE;
 237 #ifdef LDAP_AUTH_KRBV41
 238           else if (EQ (value, Qkrbv41))
 239             ldap_auth = LDAP_AUTH_KRBV41;
 240 #endif
 241 #ifdef LDAP_AUTH_KRBV42
 242           else if (EQ (value, Qkrbv42))
 243             ldap_auth = LDAP_AUTH_KRBV42;
 244 #endif
 245           else
 246             signal_simple_error ("Invalid authentication method", value);
 247         }
 248       /* Bind DN */
 249       else if (EQ (keyword, Qbinddn))
 250         {
 251           CHECK_STRING (value);
 252           GET_C_STRING_OS_DATA_ALLOCA (value, ldap_binddn);
 253         }
 254       /* Password */
 255       else if (EQ (keyword, Qpasswd))
 256         {
 257           CHECK_STRING (value);
 258           GET_C_STRING_OS_DATA_ALLOCA (value, ldap_passwd);
 259         }
 260       /* Deref */
 261       else if (EQ (keyword, Qderef))
 262         {
 263           if (EQ (value, Qnever))
 264             ldap_deref = LDAP_DEREF_NEVER;
 265           else if (EQ (value, Qsearch))
 266             ldap_deref = LDAP_DEREF_SEARCHING;
 267           else if (EQ (value, Qfind))
 268             ldap_deref = LDAP_DEREF_FINDING;
 269           else if (EQ (value, Qalways))
 270             ldap_deref = LDAP_DEREF_ALWAYS;
 271           else
 272             signal_simple_error ("Invalid deref value", value);
 273         }
 274       /* Timelimit */
 275       else if (EQ (keyword, Qtimelimit))
 276         {
 277           CHECK_INT (value);
 278           ldap_timelimit = XINT (value);
 279         }
 280       /* Sizelimit */
 281       else if (EQ (keyword, Qsizelimit))
 282         {
 283           CHECK_INT (value);
 284           ldap_sizelimit = XINT (value);
 285         }
 286     }
 287
 288   if (ldap_port == 0)
 289     {
 290       ldap_port = ldap_default_port;
 291     }
 292
 293   /* Connect to the server and bind */
 294   slow_down_interrupts ();
 295   ld = ldap_open ((char *)XSTRING_DATA (host), ldap_port);
 296   speed_up_interrupts ();
 297
 298   if (ld == NULL )
 299     signal_simple_error_2 ("Failed connecting to host",
 300                            host,
 301                            lisp_strerror (errno));
 302
 303
 304 #ifdef HAVE_LDAP_SET_OPTION
 305   if ((err = ldap_set_option (ld, LDAP_OPT_DEREF,
 306                               (void *)&ldap_deref)) != LDAP_SUCCESS)
 307     signal_ldap_error (ld, NULL, err);
 308   if ((err = ldap_set_option (ld, LDAP_OPT_TIMELIMIT,
 309                               (void *)&ldap_timelimit)) != LDAP_SUCCESS)
 310     signal_ldap_error (ld, NULL, err);
 311   if ((err = ldap_set_option (ld, LDAP_OPT_SIZELIMIT,
 312                               (void *)&ldap_sizelimit)) != LDAP_SUCCESS)
 313     signal_ldap_error (ld, NULL, err);
 314   if ((err = ldap_set_option (ld, LDAP_OPT_REFERRALS,
 315                               LDAP_OPT_ON)) != LDAP_SUCCESS)
 316     signal_ldap_error (ld, NULL, err);
 317 #else  /* not HAVE_LDAP_SET_OPTION */
 318   ld->ld_deref = ldap_deref;
 319   ld->ld_timelimit = ldap_timelimit;
 320   ld->ld_sizelimit = ldap_sizelimit;
 321 #ifdef LDAP_REFERRALS
 322   ld->ld_options = LDAP_OPT_REFERRALS;
 323 #else /* not LDAP_REFERRALS */
 324   ld->ld_options = 0;
 325 #endif /* not LDAP_REFERRALS */
 326 #endif /* not HAVE_LDAP_SET_OPTION */
 327
 328   /* ldap_bind_s calls select and may be wedged by SIGIO.  */
 329   slow_down_interrupts ();
 330   err = ldap_bind_s (ld, ldap_binddn, ldap_passwd, ldap_auth);
 331   speed_up_interrupts ();
 332   if (err != LDAP_SUCCESS)
 333     signal_simple_error ("Failed binding to the server",
 334                          build_string (ldap_err2string (err)));
 335
 336   ldap = allocate_ldap ();
 337   ldap->ld = ld;
 338   ldap->host = host;
 339
 340   return make_ldap (ldap);
 341 }
 342
 343
 344
 345 DEFUN ("ldap-close", Fldap_close, 1, 1, 0, /*
 346 Close an LDAP connection.
 347 */
 348       (ldap))
 349 {
 350   struct Lisp_LDAP *lldap;
 351   CHECK_LIVE_LDAP (ldap);
 352   lldap = XLDAP (ldap);
 353   ldap_unbind (lldap->ld);
 354   lldap->ld = NULL;
 355   return Qnil;
 356 }
 357
 358
 359 \f
 360 /************************************************************************/
 361 /*                  Working on a LDAP connection                        */
 362 /************************************************************************/
 363 struct ldap_unwind_struct
 364 {
 365   LDAPMessage *res;
 366   struct berval **vals;
 367 };
 368
 369
 370 static Lisp_Object
 371 ldap_search_unwind (Lisp_Object unwind_obj)
 372 {
 373   struct ldap_unwind_struct *unwind =
 374     (struct ldap_unwind_struct *) get_opaque_ptr (unwind_obj);
 375   if (unwind->res)
 376     ldap_msgfree (unwind->res);
 377   if (unwind->vals)
 378     ldap_value_free_len (unwind->vals);
 379   return Qnil;
 380 }
 381
 382 DEFUN ("ldap-search-internal", Fldap_search_internal, 2, 7, 0, /*
 383 Perform a search on an open LDAP connection.
 384 LDAP is an LDAP connection object created with `ldap-open'.
 385 FILTER is a filter string for the search as described in RFC 1558.
 386 BASE is the distinguished name at which to start the search.
 387 SCOPE is one of the symbols `base', `onelevel' or `subtree' indicating
 388 the scope of the search.
 389 ATTRS is a list of strings indicating which attributes to retrieve
 390  for each matching entry. If nil return all available attributes.
 391 If ATTRSONLY is non-nil then only the attributes are retrieved, not
 392 the associated values.
 393 If WITHDN is non-nil each entry in the result will be prepennded with
 394 its distinguished name DN.
 395 The function returns a list of matching entries.  Each entry is itself
 396 an alist of attribute/value pairs optionally preceded by the DN of the
 397 entry according to the value of WITHDN.
 398 */
 399        (ldap, filter, base, scope, attrs, attrsonly, withdn))
 400 {
 401   /* This function can GC */
 402
 403   /* Vars for query */
 404   LDAP *ld;
 405   LDAPMessage *e;
 406   BerElement *ptr;
 407   char *a, *dn;
 408   int i, rc, rc2;
 409   int  matches;
 410   struct ldap_unwind_struct unwind;
 411
 412   int  ldap_scope = LDAP_SCOPE_SUBTREE;
 413   char **ldap_attributes = NULL;
 414
 415   int speccount = specpdl_depth ();
 416
 417   Lisp_Object list, entry, result;
 418   struct gcpro gcpro1, gcpro2, gcpro3;
 419
 420   list = entry = result = Qnil;
 421   GCPRO3 (list, entry, result);
 422
 423   unwind.res = NULL;
 424   unwind.vals = NULL;
 425
 426   /* Do all the parameter checking  */
 427   CHECK_LIVE_LDAP (ldap);
 428   ld = XLDAP (ldap)->ld;
 429
 430   /* Filter */
 431   CHECK_STRING (filter);
 432
 433   /* Search base */
 434   if (NILP (base))
 435     {
 436       base = Vldap_default_base;
 437     }
 438   if (!NILP (base))
 439     {
 440       CHECK_STRING (base);
 441     }
 442
 443   /* Search scope */
 444   if (!NILP (scope))
 445     {
 446       if (EQ (scope, Qbase))
 447         ldap_scope = LDAP_SCOPE_BASE;
 448       else if (EQ (scope, Qonelevel))
 449         ldap_scope = LDAP_SCOPE_ONELEVEL;
 450       else if (EQ (scope, Qsubtree))
 451         ldap_scope = LDAP_SCOPE_SUBTREE;
 452       else
 453         signal_simple_error ("Invalid scope", scope);
 454     }
 455
 456   /* Attributes to search */
 457   if (!NILP (attrs))
 458     {
 459       CHECK_CONS (attrs);
 460       ldap_attributes = alloca_array (char *, 1 + XINT (Flength (attrs)));
 461
 462       i = 0;
 463       EXTERNAL_LIST_LOOP (attrs, attrs)
 464         {
 465           Lisp_Object current = XCAR (attrs);
 466           CHECK_STRING (current);
 467           GET_C_STRING_OS_DATA_ALLOCA (current, ldap_attributes[i]);
 468           ++i;
 469         }
 470       ldap_attributes[i] = NULL;
 471     }
 472
 473   /* Attributes only ? */
 474   CHECK_SYMBOL (attrsonly);
 475
 476   /* Perform the search */
 477   if (ldap_search (ld,
 478                    NILP (base) ? "" : (char *) XSTRING_DATA (base),
 479                    ldap_scope,
 480                    NILP (filter) ? "" : (char *) XSTRING_DATA (filter),
 481                    ldap_attributes,
 482                    NILP (attrsonly) ? 0 : 1)
 483       == -1)
 484     {
 485       signal_ldap_error (ld, NULL, 0);
 486     }
 487
 488   /* Ensure we don't exit without cleaning up */
 489   record_unwind_protect (ldap_search_unwind,
 490                          make_opaque_ptr (&unwind));
 491
 492   /* Build the results list */
 493   matches = 0;
 494
 495   /* ldap_result calls select() and can get wedged by EINTR signals */
 496   slow_down_interrupts ();
 497   rc = ldap_result (ld, LDAP_RES_ANY, 0, NULL, &unwind.res);
 498   speed_up_interrupts ();
 499   while (rc == LDAP_RES_SEARCH_ENTRY)
 500     {
 501       QUIT;
 502       matches ++;
 503       e = ldap_first_entry (ld, unwind.res);
 504       /* #### This call to message() is pretty fascist, because it
 505          destroys the current echo area contents, even when invoked
 506          from Lisp.  It should use echo_area_message() instead, and
 507          restore the old echo area contents later.  */
 508       message ("Parsing ldap results... %d", matches);
 509       entry = Qnil;
 510       /* Get the DN if required */
 511       if (! NILP (withdn))
 512         {
 513           dn = ldap_get_dn (ld, e);
 514           if (dn == NULL)
 515             signal_ldap_error (ld, e, 0);
 516           entry = Fcons (build_ext_string (dn, FORMAT_OS), Qnil);
 517         }
 518       for (a= ldap_first_attribute (ld, e, &ptr);
 519            a != NULL;
 520            a = ldap_next_attribute (ld, e, ptr) )
 521         {
 522           list = Fcons (build_ext_string (a, FORMAT_OS), Qnil);
 523           unwind.vals = ldap_get_values_len (ld, e, a);
 524           if (unwind.vals != NULL)
 525             {
 526               for (i = 0; unwind.vals[i] != NULL; i++)
 527                 {
 528                   list = Fcons (make_ext_string (unwind.vals[i]->bv_val,
 529                                                  unwind.vals[i]->bv_len,
 530                                                  FORMAT_OS),
 531                                 list);
 532                 }
 533             }
 534           entry = Fcons (Fnreverse (list),
 535                          entry);
 536           ldap_value_free_len (unwind.vals);
 537           unwind.vals = NULL;
 538         }
 539       result = Fcons (Fnreverse (entry),
 540                       result);
 541       ldap_msgfree (unwind.res);
 542       unwind.res = NULL;
 543
 544       slow_down_interrupts ();
 545       rc = ldap_result (ld, LDAP_RES_ANY, 0, NULL, &(unwind.res));
 546       speed_up_interrupts ();
 547     }
 548
 549   if (rc == -1)
 550     signal_ldap_error (ld, unwind.res, 0);
 551
 552   if (rc == 0)
 553     signal_ldap_error (ld, NULL, LDAP_TIMELIMIT_EXCEEDED);
 554
 555 #if defined HAVE_LDAP_PARSE_RESULT
 556   rc2 = ldap_parse_result (ld, unwind.res,
 557                            &rc,
 558                            NULL, NULL, NULL, NULL, 0);
 559   if (rc2 != LDAP_SUCCESS)
 560     rc = rc2;
 561 #elif defined HAVE_LDAP_RESULT2ERROR
 562   rc = ldap_result2error (ld, unwind.res, 0);
 563 #endif
 564   if ((rc != LDAP_SUCCESS) && (rc != LDAP_SIZELIMIT_EXCEEDED))
 565     signal_ldap_error (ld, NULL, rc);
 566
 567   ldap_msgfree (unwind.res);
 568   unwind.res = (LDAPMessage *)NULL;
 569   /* #### See above for calling message().  */
 570   message ("Parsing ldap results... done");
 571
 572   unbind_to (speccount, Qnil);
 573   UNGCPRO;
 574   return Fnreverse (result);
 575 }
 576
 577
 578 void
 579 syms_of_eldap (void)
 580 {
 581   defsymbol (&Qldapp, "ldapp");
 582   DEFSUBR (Fldapp);
 583   DEFSUBR (Fldap_host);
 584   DEFSUBR (Fldap_status);
 585   DEFSUBR (Fldap_open);
 586   DEFSUBR (Fldap_close);
 587   DEFSUBR (Fldap_search_internal);
 588 }
 589
 590 void
 591 vars_of_eldap (void)
 592 {
 593
 594   ldap_default_port = LDAP_PORT;
 595   Vldap_default_base =  Qnil;
 596
 597   DEFVAR_INT ("ldap-default-port", &ldap_default_port /*
 598 Default TCP port for LDAP connections.
 599 Initialized from the LDAP library. Default value is 389.
 600 */ );
 601
 602   DEFVAR_LISP ("ldap-default-base", &Vldap_default_base /*
 603 Default base for LDAP searches.
 604 This is a string using the syntax of RFC 1779.
 605 For instance, "o=ACME, c=US" limits the search to the
 606 Acme organization in the United States.
 607 */ );
 608
 609 }
 610
 611