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