utils.lisp

   1 (in-package :net.quadium.ldap)
   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     (ldif: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
  76 (defun compose-ldap-modify-arguments (&key
  77                                       bind-dn
  78                                       ;(password-file *password-file*)
  79                                       password-file
  80                                       password
  81                                       (simple-auth-p *simple-auth-p*)
  82                                       starttlsp
  83                                       host)
  84   "Helper function to handle arglists common to modifying functions."
  85   (format nil "~{~{ ~S~}~}"
  86           (list (when bind-dn
  87                   (list "-D" bind-dn))
  88                 (when password-file
  89                   (list "-y" *password-file*))
  90                 (when password
  91                   (list "-w" password)); TODO: remove when finished
  92                 (when simple-auth-p
  93                   (list "-x"))
  94                 (when starttlsp
  95                   (list "-ZZ"))
  96                 (when host
  97                   (list "-h" host)))))
  98
  99 (defun ldap-modify (change-records &rest args)
 100   "Transmits CHANGE-RECORDS to the LDAP server for execution."
 101   (with-open-stream (ldif (make-string-output-stream))
 102     (dolist (record change-records change-records)
 103       (ldif:write-change-record record ldif)
 104       (funcall #'trivial-shell:shell-command
 105                (concatenate 'string *ldapmodify-command*
 106                             (apply #'compose-ldap-modify-arguments args))
 107                :input (get-output-stream-string ldif)))))