utils.lisp

   1 (in-package :clldap)
   2
   3 (defun ldap-escape (string)
   4   (labels ((worker (char-list)
   5              (unless (endp char-list)
   6                (let* ((char (car char-list))
   7                       (rest (cons char (worker (cdr char-list)))))
   8                  (if (find char "\\(),!&|<>=")
   9                      (cons #\\ rest)
  10                      rest)))))
  11     (coerce (worker (coerce string 'list))
  12             'string)))
  13
  14 (defun compose-ldap-search-arguments (filter attributes
  15                                       &key
  16                                       bind-dn
  17                                       base
  18                                       (scope :sub)
  19 ;                                     (password-file *password-file*)
  20                                       password-file
  21                                       password
  22                                       (simple-auth-p *simple-auth-p*)
  23                                       starttlsp
  24                                       host)
  25   "Helper function to handle arglists common to searching functions."
  26   (format nil "~{~{ ~S~}~}"
  27           (list (when bind-dn
  28                   (list "-D" bind-dn))
  29                 (when password-file
  30                   (list "-y" (namestring (truename password-file))))
  31                 (when password
  32                   (list "-w" password)); TODO: remove when finished
  33                 (when base
  34                   (list "-b" base))
  35                 (when simple-auth-p
  36                   (list "-x"))
  37                 (when starttlsp
  38                   (list "-ZZ"))
  39                 (when host
  40                   (list "-h" host))
  41                 (list "-s" (ecase scope
  42                              (:sub "sub")
  43                              (:base "base")
  44                              (:one "one")))
  45                 (list "-LLL")
  46                 (list
  47                  (cond
  48                    ((zerop (length filter)) "(objectClass=*)")
  49                    ((stringp filter) filter)
  50                    ((listp filter) (convert-search-filter filter))))
  51                 attributes)))
  52
  53 (defun ldap-search (&rest args)
  54   "Searches by FILTER and returns matching ATTRIBUTES.
  55 FILTER may be a filter string in the form expected by ldap_search(3),
  56 or a sexp which will be converted by CONVERT-SEARCH-FILTER.  A null
  57 FILTER is equivalent to \"(objectClass=*)\".  ATTRIBUTES is a list of
  58 strings, each string designating the name of an attribute.  If
  59 ATTRIBUTES is empty, all attributes of a matching record will be
  60 returned."
  61   (with-input-from-string (ldif (funcall #'trivial-shell:shell-command
  62                                          (concatenate 'string *ldapsearch-command*
  63                                                       (apply #'compose-ldap-search-arguments args))))
  64     (parse-ldif-stream ldif)))
  65
  66 (defun ldap-fetch-by-dn (dn attributes
  67                          &rest args)
  68   "Fetches the object designated by the distinguished name DN.
  69 ATTRIBUTES are handled as by LDAP-SEARCH."
  70   (car (apply 'ldap-search "" attributes
  71               :base dn
  72               :scope :base
  73               args)))
  74
  75 (defun compose-ldap-modify-arguments (&key
  76                                       bind-dn
  77                                       ;(password-file *password-file*)
  78                                       password-file
  79                                       password
  80                                       (simple-auth-p *simple-auth-p*)
  81                                       starttlsp
  82                                       host)
  83   "Helper function to handle arglists common to modifying functions."
  84   (format nil "~{~{ ~S~}~}"
  85           (list (when bind-dn
  86                   (list "-D" bind-dn))
  87                 (when password-file
  88                   (list "-y" *password-file*))
  89                 (when password
  90                   (list "-w" password)); TODO: remove when finished
  91                 (when simple-auth-p
  92                   (list "-x"))
  93                 (when starttlsp
  94                   (list "-ZZ"))
  95                 (when host
  96                   (list "-h" host)))))
  97
  98 (defun ldap-modify (change-records &rest args)
  99   "Transmits CHANGE-RECORDS to the LDAP server for execution."
 100   (with-open-stream (ldif (make-string-output-stream))
 101     (dolist (record change-records change-records)
 102       (write-change-record record ldif)
 103       (funcall #'trivial-shell:shell-command
 104                (concatenate 'string *ldapmodify-command*
 105                             (apply #'compose-ldap-modify-arguments args))
 106                :input (get-output-stream-string ldif)))))
 107
 108
 109 (defun ldap-delete-by-dn (dn &rest args)
 110   "Delete record with dn"
 111   (funcall #'trivial-shell:shell-command
 112            (concatenate 'string *ldapdelete-command*
 113                         (apply #'compose-ldap-modify-arguments args)
 114                         " " dn)))
 115