X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/1259009aa17da6dc038afff96963f6d9bbd3b8e1..ac5475dacb20d240db27d56199910d8a6fcc90e8:/lisp/net/ldap.el

diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 941b6d7787..a77fc3c651 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -1,9 +1,9 @@
 ;;; ldap.el --- client interface to LDAP for Emacs
 
-;; Copyright (C) 1998-2012  Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
 
 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
 ;; Created: April 1998
 ;; Keywords: comm
 
@@ -34,7 +34,7 @@
 ;;; Code:
 
 (require 'custom)
-(eval-when-compile (require 'cl))
+(require 'password-cache)
 
 (autoload 'auth-source-search "auth-source")
 
@@ -48,15 +48,13 @@
 A TCP port number can be appended to that name using a colon as
 a separator."
   :type '(choice (string :tag "Host name")
-		 (const :tag "Use library default" nil))
-  :group 'ldap)
+		 (const :tag "Use library default" nil)))
 
 (defcustom ldap-default-port nil
   "Default TCP port for LDAP connections.
 Initialized from the LDAP library at build time. Default value is 389."
   :type '(choice (const :tag "Use library default" nil)
-		 (integer :tag "Port number"))
-  :group 'ldap)
+		 (integer :tag "Port number")))
 
 (defcustom ldap-default-base nil
   "Default base for LDAP searches.
@@ -64,8 +62,7 @@ This is a string using the syntax of RFC 1779.
 For instance, \"o=ACME, c=US\" limits the search to the
 Acme organization in the United States."
   :type '(choice (const :tag "Use library default" nil)
-		 (string :tag "Search base"))
-  :group 'ldap)
+		 (string :tag "Search base")))
 
 
 (defcustom ldap-host-parameters-alist nil
@@ -145,35 +142,35 @@ Valid properties include:
 				   :tag "Size Limit"
 				   :inline t
 				   (const :tag "Size Limit" sizelimit)
-				   (integer :tag "(number of records)")))))
-  :group 'ldap)
+				   (integer :tag "(number of records)"))))))
 
 (defcustom ldap-ldapsearch-prog "ldapsearch"
   "The name of the ldapsearch command line program."
-  :type '(string :tag "`ldapsearch' Program")
-  :group 'ldap)
+  :type '(string :tag "`ldapsearch' Program"))
 
 (defcustom ldap-ldapsearch-args '("-LL" "-tt")
   "A list of additional arguments to pass to `ldapsearch'."
   :type '(repeat :tag "`ldapsearch' Arguments"
-		 (string :tag "Argument"))
-  :group 'ldap)
+		 (string :tag "Argument")))
+
+(defcustom ldap-ldapsearch-password-prompt-regexp "Enter LDAP Password: "
+  "A regular expression used to recognize the `ldapsearch'
+program's password prompt."
+  :type 'regexp
+  :version "25.1")
 
 (defcustom ldap-ignore-attribute-codings nil
   "If non-nil, do not encode/decode LDAP attribute values."
-  :type 'boolean
-  :group 'ldap)
+  :type 'boolean)
 
 (defcustom ldap-default-attribute-decoder nil
   "Decoder function to use for attributes whose syntax is unknown."
-  :type 'symbol
-  :group 'ldap)
+  :type 'symbol)
 
 (defcustom ldap-coding-system 'utf-8
   "Coding system of LDAP string values.
 LDAP v3 specifies the coding system of strings to be UTF-8."
-  :type 'symbol
-  :group 'ldap)
+  :type 'symbol)
 
 (defvar ldap-attribute-syntax-encoders
   [nil					; 1  ACI Item                        N
@@ -465,18 +462,59 @@ Additional search parameters can be specified through
       (error "No LDAP host specified"))
   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 	result)
-    (setq result (ldap-search-internal (list* 'host host
-					      'filter filter
-					      'attributes attributes
-					      'attrsonly attrsonly
-					      'withdn withdn
-					      host-plist)))
+    (setq result (ldap-search-internal `(host ,host
+					 filter ,filter
+                                         attributes ,attributes
+                                         attrsonly ,attrsonly
+                                         withdn ,withdn
+                                         ,@host-plist)))
     (if ldap-ignore-attribute-codings
 	result
       (mapcar (lambda (record)
 		(mapcar 'ldap-decode-attribute record))
 	      result))))
 
+(defun ldap-password-read (host)
+  "Read LDAP password for HOST.
+If the password is cached, it is read from the cache, otherwise the user
+is prompted for the password.  If `password-cache' is non-nil the password
+is verified and cached.  The `password-cache-expiry' variable
+controls for how long the password is cached.
+
+This function can be specified for the `passwd' property in
+`ldap-host-parameters-alist' when interactive password prompting
+is desired for HOST."
+  ;; Add ldap: namespace to allow empty string for default host.
+  (let* ((host-key (concat "ldap:" host))
+	 (password (password-read
+		    (format "Enter LDAP Password%s: "
+			    (if (equal host "")
+				""
+			      (format " for %s" host)))
+		    host-key)))
+    (when (and password-cache
+	       (not (password-in-cache-p host-key))
+	       ;; Confirm the password is valid before adding it to
+	       ;; the password cache.  ldap-search-internal will throw
+	       ;; an error if the password is invalid.
+	       (not (ldap-search-internal
+		     `(host ,host
+			    ;; Specify an arbitrary filter that should
+			    ;; produce no results, since only
+			    ;; authentication success is of interest.
+			    filter "emacs-test-password="
+			    attributes nil
+			    attrsonly nil
+			    withdn nil
+			    ;; Preempt passwd ldap-password-read
+			    ;; setting in ldap-host-parameters-alist.
+			    passwd ,password
+			    ,@(cdr
+			       (assoc
+				host
+				ldap-host-parameters-alist))))))
+      (password-cache-add host-key password))
+    password))
 
 (defun ldap-search-internal (search-plist)
   "Perform a search on a LDAP server.
@@ -532,7 +570,11 @@ an alist of attribute/value pairs."
          (passwd (or (plist-get search-plist 'passwd)
                      (plist-get asfound :secret)))
          ;; convert the password from a function call if needed
-         (passwd (if (functionp passwd) (funcall passwd) passwd))
+         (passwd (if (functionp passwd)
+		     (if (eq passwd 'ldap-password-read)
+			 (funcall passwd host)
+		       (funcall passwd))
+		   passwd))
          ;; get the binddn from the search-list or from the
          ;; auth-source user or binddn tokens
          (binddn (or (plist-get search-plist 'binddn)
@@ -551,7 +593,7 @@ an alist of attribute/value pairs."
 	(sizelimit (plist-get search-plist 'sizelimit))
 	(withdn (plist-get search-plist 'withdn))
 	(numres 0)
-	arglist dn name value record result)
+	arglist dn name value record result proc)
     (if (or (null filter)
 	    (equal "" filter))
 	(error "No search filter"))
@@ -560,7 +602,13 @@ an alist of attribute/value pairs."
       (erase-buffer)
       (if (and host
 	       (not (equal "" host)))
-	  (setq arglist (nconc arglist (list (format "-h%s" host)))))
+	  (setq arglist (nconc arglist
+			       (list (format
+				      ;; Use -H if host is a new-style LDAP URI.
+				      (if (string-match "^[a-zA-Z]+://" host)
+					  "-H%s"
+					"-h%s")
+				      host)))))
       (if (and attrsonly
 	       (not (equal "" attrsonly)))
 	  (setq arglist (nconc arglist (list "-A"))))
@@ -576,9 +624,9 @@ an alist of attribute/value pairs."
       (if (and auth
 	       (equal 'simple auth))
 	  (setq arglist (nconc arglist (list "-x"))))
-      (if (and passwd
-	       (not (equal "" passwd)))
-	  (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
+      ;; Allow passwd to be set to "", representing a blank password.
+      (if passwd
+	  (setq arglist (nconc arglist (list "-W"))))
       (if (and deref
 	       (not (equal "" deref)))
 	  (setq arglist (nconc arglist (list (format "-a%s" deref)))))
@@ -588,14 +636,43 @@ an alist of attribute/value pairs."
       (if (and sizelimit
 	       (not (equal "" sizelimit)))
 	  (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
-      (apply #'call-process ldap-ldapsearch-prog
-	     ;; Ignore stderr, which can corrupt results
-	     nil (list buf nil) nil
-	     (append arglist ldap-ldapsearch-args filter))
+      (if passwd
+	  (let* ((process-connection-type nil)
+		 (proc-args (append arglist ldap-ldapsearch-args
+				    filter))
+		 (proc (apply #'start-process "ldapsearch" buf
+			      ldap-ldapsearch-prog
+			      proc-args)))
+	    (while (null (progn
+			   (goto-char (point-min))
+			   (re-search-forward
+			    ldap-ldapsearch-password-prompt-regexp
+			    (point-max) t)))
+	      (accept-process-output proc 1))
+	    (process-send-string proc passwd)
+	    (process-send-string proc "\n")
+	    (while (not (memq (process-status proc) '(exit signal)))
+	      (sit-for 0.1))
+	    (let ((status (process-exit-status proc)))
+	      (when (not (eq status 0))
+		;; Handle invalid credentials exit status specially
+		;; for ldap-password-read.
+		(if (eq status 49)
+		    (error (concat "Incorrect LDAP password or"
+				   " bind distinguished name (binddn)"))
+		  (error "Failed ldapsearch invocation: %s \"%s\""
+			 ldap-ldapsearch-prog
+			 (mapconcat 'identity proc-args "\" \""))))))
+	(apply #'call-process ldap-ldapsearch-prog
+	       ;; Ignore stderr, which can corrupt results
+	       nil (list buf nil) nil
+	       (append arglist ldap-ldapsearch-args filter)))
       (insert "\n")
       (goto-char (point-min))
 
-      (while (re-search-forward "[\t\n\f]+ " nil t)
+      (while (re-search-forward (concat "[\t\n\f]+ \\|"
+					ldap-ldapsearch-password-prompt-regexp)
+				nil t)
 	(replace-match "" nil nil))
       (goto-char (point-min))
 
@@ -605,6 +682,7 @@ an alist of attribute/value pairs."
 	;; Skip error message when retrieving attribute list
 	(if (looking-at "Size limit exceeded")
 	    (forward-line 1))
+        (if (looking-at "version:") (forward-line 1)) ;bug#12724.
 	(while (progn
 		 (skip-chars-forward " \t\n")
 		 (not (eobp)))