ldap.lisp

(in-package #:org.shirakumo.ldapper)

(defvar +ldap-disconnect+ "1.3.6.1.4.1.1466.20036")
(defvar +ldap-control-extension-paging+ "1.2.840.113556.1.4.319")

(defun vec (&optional initial-contents)
  (make-array (length initial-contents) :adjustable T :fill-pointer T :element-type '(unsigned-byte 8) :initial-contents initial-contents))

(defun vector-append-extend (new vec)
  (loop for el across new
        do (vector-push-extend el vec))
  vec)

(defmacro define-map ((a b) &body pairs)
  `(progn
     (defun ,(intern (format NIL "~a->~a" a b)) (thing)
       (ecase thing
         ,@(loop for (a b) in pairs collect (list a `',b))))
     (defun ,(intern (format NIL "~a->~a" b a)) (thing)
       (ecase thing
         ,@(loop for (a b) in pairs collect (list b `',a))))))

(define-map (id ber-class)
  (#b00000000 :universal)
  (#b01000000 :application)
  (#b10000000 :context)
  (#b11000000 :private))

(defun ber-p/c-bit (p/c)
  (ecase p/c
    (:primitive   #b00000000)
    (:constructed #b00100000)))

(defun ber-tag-type (class p/c)
  (logior (ber-class->id class) (ber-p/c-bit p/c)))

(defun encode-ber-tag (class p/c number-or-command &optional (vec (vec)))
  (let ((byte (ber-tag-type class p/c))
	(number (etypecase number-or-command
		  (integer number-or-command)
		  (symbol (ldap-command->id number-or-command)))))
    (cond ((< number 31)
           (vector-push-extend (logior byte number) vec))
	  ((< number 128)
           (vector-push-extend (logior byte #b00011111) vec)
           (vector-push-extend number vec))
	  (T (error "Length of tag exceeds maximum bounds (0-127).")))
    vec))

(defun decode-ber-tag (vector &optional (start 0))
  (let* ((byte (aref vector start))
         (class (id->ber-class (logand #b11000000 byte)))
         (p/c (if (logtest #b00100000 byte) :constructed :primitive))
         (id (logand #b00011111 byte)))
    (incf start)
    (when (= #b00011111 id)
      (setf id (aref vector start))
      (incf start))
    (values class p/c id start)))

(defun encode-ber-length (length &optional (vec (vec)))
  (cond ((< length 128)
         (vector-push-extend length vec))
        ((< length (- (expt 2 31) 1))
         (let ((bytes (ceiling (integer-length length) 8)))
           (vector-push-extend (logior bytes #b10000000) vec)
           (loop for i downfrom (1- bytes) to 0
                 do (vector-push-extend (ldb (byte 8 (* 8 i)) length) vec))))
        (t (error "Length exceeds maximum bounds"))))

(defun decode-ber-length (vec &optional (start 0))
  (let ((head (aref vec start)))
    (incf start)
    (if (< head 128)
        (values head start)
        (let ((bytes (logand head #b01111111))
              (int 0))
          (loop for i downfrom (1- bytes) to 0
                do (setf (ldb (byte 8 (* 8 i)) int) (aref vec start))
                   (incf start))
          (values int start)))))

(defun read-ber-length (stream)
  (let ((head (read-byte stream)))
    (if (< head 128)
        head
        (let ((bytes (logand head #b01111111))
              (int 0))
          (loop for i downfrom (1- bytes) to 0
                do (setf (ldb (byte 8 (* 8 i)) int) (read-byte stream)))
          int))))

(defun encode-ber-sequence (tag data &optional (vec (vec)))
  (vector-append-extend (ber-tag tag) vec)
  (encode-ber-length (length data) vec)
  (vector-append-extend data vec))

(defun decode-ber-sequence (vec &optional (start 0))
  (multiple-value-bind (length start) (decode-ber-length vec start)
    (values (subseq vec start (+ start length))
            (+ start length))))

(defun encode-ber-integer (tag int &optional (vec (vec)))
  (vector-append-extend (ber-tag tag) vec)
  (let ((bytes (max 1 (ceiling (integer-length int) 8))))
    (vector-push-extend bytes vec)
    (loop for i downfrom (1- bytes) to 0
          do (vector-push-extend (ldb (byte 8 (* 8 i)) int) vec)))
  vec)

(defun decode-ber-integer (vec &optional (start 0))
  (let ((bytes (aref vec start))
        (int 0))
    (incf start)
    (loop for i downfrom (1- bytes) to 0
          do (setf (ldb (byte 8 (* 8 i)) int) (aref vec start))
             (incf start))
    (values int start)))

(define-map (id ldap-command)
  (0  :bind-request)
  (1  :bind-response)
  (2  :unbind-request)
  (3  :search-request)
  (4  :search-result-entry)
  (5  :search-result-done)
  (6  :modify-request)
  (7  :modify-response)
  (8  :add-request)
  (9  :add-response)
  (10 :del-request)
  (11 :del-response)
  (12 :modify-dn-request)
  (13 :modify-dn-response)
  (14 :compare-request)
  (15 :compare-response)
  (16 :abandon-request)
  (19 :search-result-reference)
  (23 :extended-request)
  (24 :extended-response))

(define-map (id ldap-result-code)
  (0  :success)
  (1  :operations-error)
  (2  :protocol-error)
  (3  :time-limit-exceeded)
  (4  :size-limit-exceeded)
  (5  :compare-false)
  (6  :compare-true)
  (7  :auth-method-not-supported)
  (8  :strong-auth-required)
  (10 :referral)
  (11 :admin-limit-exceeded)
  (12 :unavailable-critical-extension)
  (13 :confidentiality-required)
  (14 :sasl-bind-in-progress)
  (16 :no-such-attribute)
  (17 :undefined-attribute-type)
  (18 :inappropriate-matching)
  (19 :constraint-violation)
  (20 :attribute-or-value-exists)
  (21 :invalid-attribute-syntax)
  (32 :no-such-object)
  (33 :alias-problem)
  (34 :invalid-dn-syntax)
  (36 :alias-dereferencing-problem)
  (48 :inappropriate-authentication)
  (49 :invalid-credentials)
  (50 :insufficient-access-rights)
  (51 :busy)
  (52 :unavailable)
  (53 :unwilling-to-perform)
  (54 :loop-detect)
  (64 :naming-violation)
  (65 :object-class-violation)
  (66 :not-allowed-on-leaf)
  (67 :not-allowed-on-rdn)
  (68 :entry-already-exists)
  (69 :object-class-mods-prohibited)
  (71 :affects-multiple-dsas)
  (80 :other))

(define-map (id ldap-scope)
  (0 :base)
  (1 :one)
  (2 :sub))

(define-map (id ldap-deref)
  (0 :never)
  (1 :search)
  (2 :find)
  (3 :always))

(define-map (id ldap-modify-type)
  (0 :add)
  (1 :delete)
  (2 :replace))

(define-map (id ldap-enum)
  (0 :base)
  (1 :one)
  (2 :sub)
  (0 :never)
  (1 :search)
  (2 :find)
  (3 :always)
  (0 :add)
  (1 :delete)
  (2 :replace))

(define-map (id ldap-filter)
  (0 :and)
  (1 :or)
  (2 :not)
  (3 :=)
  (4 :substring)
  (5 :>=)
  (6 :<=)
  (7 :=*)
  (8 :~=))

(define-map (id ldap-substring)
  (0 :starts-with)
  (1 :search)
  (2 :ends-with))

(defvar *ber-tags* (make-hash-table :test 'eql))

(defun ber-tag (name)
  (or (gethash name *ber-tags*)
      (error "No such tag ~s" name)))

(defun (setf ber-tag) (tag name)
  (when (= 1 (length tag))
    (setf (gethash (aref tag 0) *ber-tags*) name))
  (setf (gethash name *ber-tags*) tag))

(setf (ber-tag 'bind) (encode-ber-tag :application :constructed :bind-request))
(setf (ber-tag 'bind-response) (encode-ber-tag :application :constructed :bind-response))
(setf (ber-tag 'unbind) (encode-ber-tag :application :primitive :unbind-request))
(setf (ber-tag 'lookup) (encode-ber-tag :application :constructed :search-request))
(setf (ber-tag 'lookup-entry) (encode-ber-tag :application :constructed :search-result-entry))
(setf (ber-tag 'lookup-done) (encode-ber-tag :application :constructed :search-result-done))
(setf (ber-tag 'modify) (encode-ber-tag :application :constructed :modify-request))
(setf (ber-tag 'modify-response) (encode-ber-tag :application :constructed :modify-response))
(setf (ber-tag 'add) (encode-ber-tag :application :constructed :add-request))
(setf (ber-tag 'add-response) (encode-ber-tag :application :constructed :add-response))
(setf (ber-tag 'del) (encode-ber-tag :application :primitive :del-request))
(setf (ber-tag 'del-response) (encode-ber-tag :application :primitive :del-response))
(setf (ber-tag 'moddn) (encode-ber-tag :application :constructed :modify-dn-request))
(setf (ber-tag 'moddn-response) (encode-ber-tag :application :constructed :modify-dn-response))
(setf (ber-tag 'comp) (encode-ber-tag :application :constructed :compare-request))
(setf (ber-tag 'comp-response) (encode-ber-tag :application :constructed :compare-response))
(setf (ber-tag 'abandon) (encode-ber-tag :application :primitive :abandon-request))
(setf (ber-tag 'lookup-reference) (encode-ber-tag :application :primitive :search-result-reference))
(setf (ber-tag 'extended) (encode-ber-tag :application :constructed :extended-request))
(setf (ber-tag 'extended-response) (encode-ber-tag :application :constructed :extended-response))
(setf (ber-tag :controls) (encode-ber-tag :context :constructed 0))
(setf (ber-tag :referral) (encode-ber-tag :context :constructed :search-request))
(setf (ber-tag :ext-name) (encode-ber-tag :context :primitive 10))
(setf (ber-tag :ext-val) (encode-ber-tag :context :primitive 11))
(setf (ber-tag :bool) (encode-ber-tag :universal :primitive #x01))
(setf (ber-tag :int) (encode-ber-tag :universal :primitive #x02))
(setf (ber-tag :str) (encode-ber-tag :universal :primitive #x04))
(setf (ber-tag :null) (encode-ber-tag :universal :primitive #x05))
(setf (ber-tag :enum) (encode-ber-tag :universal :primitive #x0A))
(setf (ber-tag :seq) (encode-ber-tag :universal :constructed #x10))
(setf (ber-tag :set) (encode-ber-tag :universal :constructed #x11))

(defun encode-null (&optional (vec (vec)))
  (encode-ber-sequence :null #() vec))

(defun encode-boolean (boolean &optional (vec (vec)))
  (encode-ber-integer :bool (if boolean #xFF #x00) vec))

(defun encode-integer (int &optional (vec (vec)))
  (encode-ber-integer :int int vec))

(defun encode-enum (keyword &optional (vec (vec)))
  (encode-ber-integer :enum (etypecase keyword (keyword (ldap-enum->id keyword)) (integer keyword)) vec))

(defun encode-string (string &optional (vec (vec)))
  (encode-ber-sequence :str (babel:string-to-octets string :encoding :utf-8) vec))

(defun encode-sequence (seq &optional (vec (vec)))
  (encode-ber-sequence :seq seq vec))

(defun encode-set (set &optional (vec (vec)))
  (let ((setvec (vec)))
    (dolist (part set) (vector-append-extend part setvec))
    (encode-ber-sequence :set setvec vec)))

(defun encode-kv (attribute values &optional (vec (vec)))
  (encode attribute vec)
  (encode (mapcar #'encode (if (listp values) values (list values))) vec)
  vec)

(defun encode-alist (alist &optional (vec (vec)))
  (loop for (attribute . values) in alist
        do (encode (encode-kv attribute values) vec))
  vec)

(defgeneric encode-object (object vec))

(defun encode (thing &optional (vec (vec)))
  (typecase thing
    ((eql null) (encode-null vec))
    ((member T NIL) (encode-boolean thing vec))
    (integer (encode-integer thing vec))
    (keyword (encode-enum thing vec))
    (string (encode-string thing vec))
    (vector (encode-sequence thing vec))
    (cons (encode-set thing vec))
    (T (encode-ber-sequence (tag thing) (encode-object thing (vec)) vec))))

(defun encode* (&rest parts)
  (let ((vec (make-array 0 :adjustable T :fill-pointer T :element-type '(unsigned-byte 8))))
    (dolist (part parts vec)
      (encode part vec))))

(defun decode-string (vec &optional (start 0))
  (multiple-value-bind (length start) (decode-ber-length vec start)
    (values (babel:octets-to-string vec :start start :end (+ start length) :encoding :latin-1)
            (+ start length))))

(defun check-ber-tag (vec start class p/c id)
  (multiple-value-bind (actual-class actual-p/c actual-id start) (decode-ber-tag vec start)
    (assert (eql actual-class class))
    (assert (eql actual-p/c p/c))
    (assert (= actual-id id))
    start))

(defgeneric decode-object (object vec start end))

(defun decode (vec &optional (start 0))
  (let ((tag (gethash (aref vec start) *ber-tags*)))
    (incf start)
    (case tag
      ((NIL) (values (1- start) most-positive-fixnum))
      (:null (values 'null (1+ start)))
      (:bool (values (< 0 (aref vec (1+ start))) (+ start 2)))
      (:int (decode-ber-integer vec start))
      (:enum (decode-ber-integer vec start))
      (:str (multiple-value-bind (octets start) (decode-ber-sequence vec start)
              (values (babel:octets-to-string octets :encoding :utf-8) start)))
      (:seq (decode-ber-sequence vec start))
      (:set (decode-ber-sequence vec start))
      (T (multiple-value-bind (length start) (decode-ber-length vec start)
           (decode-object tag vec start (+ start length)))))))

(defun decode* (vec &optional (start 0) (end (length vec)) &key (count most-positive-fixnum))
  (values (loop while (< start end)
                repeat count
                collect (multiple-value-bind (object next) (decode vec start)
                          (setf start next)
                          object))
          start))

(defmacro with-decoding (parts (vec &rest decode-args) &body body)
  (let ((p (gensym "PARTS"))
        (s (gensym "START")))
    `(multiple-value-bind (,p ,(or (first decode-args) s)) (decode* ,vec ,@decode-args)
       (declare (ignorable ,(or (first decode-args) s)))
       (destructuring-bind ,parts ,p
         ,@body))))

(defun encode-message (object)
  (let ((vec (vec)))
    (encode (id object) vec)
    (encode object vec)
    (encode vec)))

(defun decode-message (vec &optional (start 0))
  (multiple-value-bind (id off) (decode vec start)
    (let ((message (decode vec off)))
      (setf (id message) id)
      (values message start))))