ffi.rkt

#lang racket/base

(require ffi/unsafe
         ffi/unsafe/define
         ffi/unsafe/define/conventions)

(provide
 ldap-initialize
 ldap-set-option
 ldap-sasl-bind-s
 ldap-unbind-ext-s
 ldap-search-ext-s
 ldap-compare-ext-s
 ldap-err2string
 ldap-get-dn
 ldap-first-attribute
 ldap-next-attribute
 ldap-get-values-len
 ldap-count-values-len
 ldap-value-free-len
 ldap-first-entry
 ldap-next-entry
 ldap-count-entries
 ldap-add-ext-s
 ldap-modify-ext-s
 ldap-passwd-s
 ldap-rename-s
 ldap-delete-ext-s
 get-ber-value)

(define-ffi-definer defldap (ffi-lib "libldap-2.4" '("2" "4"))
  #:make-c-id convention:hyphen->underscore
  #:default-make-fail make-not-available)

;; typedef struct ldap LDAP;
(define _ldap-pointer (_or-null (_cpointer 'ldap)))

;; _array/list with 0 as last item
(define (_array/list/zero type)
  (make-ctype _pointer
              (λ (lst)
                (list->cblock (append lst '(#f)) type))
              #f))

#|
/* structure for returning a sequence of octet strings + length */
typedef struct berval {
        ber_len_t    bv_len;
        char        *bv_val;
} BerValue;
|#
(define-cstruct _berval
  ([bv_len _ulong]
   [bv_val _string]))

#|
/*
 * This structure represents both ldap messages and ldap responses.
 * These are really the same, except in the case of search responses,
 * where a response has multiple messages.
 */

struct ldapmsg {
        ber_int_t       lm_msgid;      /* the message id */
        ber_tag_t       lm_msgtype;    /* the message type */
        BerElement     *lm_ber;        /* the ber encoded message contents */
        struct ldapmsg *lm_chain;      /* for search - next msg in the resp */
        struct ldapmsg *lm_chain_tail;
        struct ldapmsg *lm_next;       /* next response */
        time_t          lm_time;       /* used to maintain cache */
};
|#
#;(define-cstruct _ldapmsg
    ([lm_msgid      _int]
     [lm_msgtype    _int]
     [lm_ber        _pointer]
     [lm_chain      _ldapmsg-pointer/null]
     [lm_chain_tail _ldapmsg-pointer/null]
     [lm_next       _ldapmsg-pointer/null]
     [lm_time       _ulong]))

#;(define ld (make-ldapmsg 0 0 #f #f #f #f 0))

#|
LDAP_F( int )
ldap_initialize LDAP_P((
    LDAP **ldp,
    LDAP_CONST char *url ));
|#
;; initialize the LDAP library without opening
;; a connection to a server
(defldap ldap-initialize (_fun [ld : (_ptr o _ldap-pointer)]
                               _string
                               -> [r : _int]
                               -> (values r ld)))

#|
LDAP_F( int )
ldap_set_option LDAP_P((
        LDAP *ld,
        int option,
        LDAP_CONST void *invalue));
|#
(defldap ldap-set-option (_fun _pointer
                               _int
                               (_ptr i _int)
                               -> _int))

#|
LDAP_F( int )
ldap_sasl_bind_s LDAP_P((
        LDAP            *ld,
        LDAP_CONST char *dn,
        LDAP_CONST char *mechanism,
        struct berval   *cred,
        LDAPControl     **serverctrls,
        LDAPControl     **clientctrls,
        struct berval   **servercredp ));
|#
(defldap ldap-sasl-bind-s (_fun _pointer
                                _string
                                _int
                                [pswd : _?] ;; pswd is used for pre-processing
                                [_berval-pointer = (make-berval
                                                    (string-length pswd)
                                                    pswd)]
                                _pointer
                                _pointer
                                _berval-pointer/null
                                -> _int))

#|
LDAP_F( int )
ldap_unbind_ext_s LDAP_P((
        LDAP        *ld,
        LDAPControl **serverctrls,
        LDAPControl **clientctrls));
|#
(defldap ldap-unbind-ext-s (_fun _pointer
                                 _pointer
                                 _pointer
                                 -> _int))

#|
LDAP_F( int )
ldap_search_ext_s LDAP_P((
        LDAP               *ld,
        LDAP_CONST char    *base,
        int                scope,
        LDAP_CONST char    *filter,
        char               **attrs,
        int                attrsonly,
        LDAPControl        **serverctrls,
        LDAPControl        **clientctrls,
        struct timeval     *timeout,
        int                sizelimit,
        LDAPMessage        **res ));
|#
(defldap ldap-search-ext-s (_fun _pointer
                                 _string
                                 _int
                                 _string
                                 _pointer
                                 _int
                                 _pointer
                                 _pointer
                                 _pointer
                                 _int
                                 (res : (_ptr o _pointer))
                                 -> (r : _int)
                                 -> (values r res)))

#|
LDAP_F( int )
ldap_compare_ext_s LDAP_P((
        LDAP *ld,
        LDAP_CONST char *dn,
        LDAP_CONST char *attr,
        struct berval   *bvalue,
        LDAPControl             **serverctrls,
        LDAPControl             **clientctrls ));
|#
(defldap ldap-compare-ext-s (_fun _pointer
                                  _string
                                  _string
                                  [value : _?] ;; value is used for pre-processing
                                  [_berval-pointer = (make-berval
                                                       (string-length value)
                                                       value)]
                                  _pointer
                                  _pointer
                                  -> _int))

;; LDAP_F( char * ) ldap_err2string LDAP_P(( int err ));
(defldap ldap-err2string (_fun _int
                               -> _string))

;; LDAP_F( char * ) ldap_get_dn LDAP_P((LDAP *ld, LDAPMessage *entry ));
(defldap ldap-get-dn (_fun _pointer
                           _pointer
                           -> _string))

#|
LDAP_F( char * )
ldap_first_attribute LDAP_P((
        LDAP *ld,
        LDAPMessage *entry,
        BerElement **ber ));
|#
(defldap ldap-first-attribute (_fun _pointer
                                    _pointer
                                    (ber : (_ptr o _pointer))
                                    -> (fst-attr : _string)
                                    -> (values fst-attr ber)))

#|
LDAP_F( char * )
ldap_next_attribute LDAP_P((
        LDAP *ld,
        LDAPMessage *entry,
        BerElement *ber ));
|#
(defldap ldap-next-attribute (_fun _pointer
                                   _pointer
                                   _pointer
                                   -> _string))

#|
LDAP_F( struct berval ** )
ldap_get_values_len LDAP_P((
        LDAP *ld,
        LDAPMessage *entry,
        LDAP_CONST char *target ));
|#
(defldap ldap-get-values-len (_fun _pointer
                                   _pointer
                                   _string
                                   -> _berval-pointer))

;; LDAP_F( int ) ldap_count_values_len LDAP_P(( struct berval **vals ));
(defldap ldap-count-values-len (_fun _berval-pointer
                                     -> _int))

;; LDAP_F( void ) ldap_value_free_len LDAP_P(( struct berval **vals ));
(defldap ldap-value-free-len (_fun _berval-pointer
                                   -> _void))

;; LDAP_F( LDAPMessage * ) ldap_first_entry LDAP_P(( LDAP *ld, LDAPMessage *chain ));
(defldap ldap-first-entry (_fun _pointer
                                _pointer
                                -> _pointer))


;; LDAP_F( LDAPMessage * ) ldap_next_entry LDAP_P(( LDAP *ld, LDAPMessage *entry ));
(defldap ldap-next-entry (_fun _pointer
                               _pointer
                               -> _pointer))

;; LDAP_F( int ) ldap_count_entries LDAP_P((LDAP *ld, LDAPMessage *chain ));
(defldap ldap-count-entries (_fun _pointer
                                  _pointer
                                  -> _int))

#|
/* for modifications */
typedef struct ldapmod {
        int    mod_op;

#define LDAP_MOD_OP           (0x0007)
#define LDAP_MOD_ADD          (0x0000)
#define LDAP_MOD_DELETE       (0x0001)
#define LDAP_MOD_REPLACE      (0x0002)
#define LDAP_MOD_INCREMENT    (0x0003) /* OpenLDAP extension */
#define LDAP_MOD_BVALUES      (0x0080)
/* IMPORTANT: do not use code 0x1000 (or above),
 * it is used internally by the backends!
 * (see ldap/servers/slapd/slap.h)
 */
        char           *mod_type;
        union mod_vals_u {
        char           **modv_strvals;
        struct berval  **modv_bvals;
} mod_vals;
#define mod_values     mod_vals.modv_strvals
#define mod_bvalues    mod_vals.modv_bvals
} LDAPMod;
|#

(define-cstruct _ldapmod
  ([mod_op      _int]
   [mod_type    _string]
   [mod_values  (_array/list/zero _string)]
   #;[mod_bvalues _pointer]))

(define _c-ldap-mod _ldapmod-pointer/null)


(define _ldapmod/list
  (make-ctype _ldapmod-pointer/null
              (λ (lst)
                (if lst (apply make-ldapmod lst) #f))
              #f))

#|
LDAP_F( int )
ldap_add_ext_s LDAP_P((
        LDAP             *ld,
        LDAP_CONST char  *dn,
        LDAPMod         **attrs,
        LDAPControl     **serverctrls,
        LDAPControl     **clientctrls ));
|#
(defldap ldap-add-ext-s (_fun _pointer
                              _string
                              (_array/list/zero _ldapmod/list)
                              _pointer
                              _pointer
                              -> _int))

#|
LDAP_F( int )
ldap_modify_ext_s LDAP_P((
    LDAP            *ld,
    LDAP_CONST char *dn,
    LDAPMod         **mods,
    LDAPControl     **serverctrls,
    LDAPControl     **clientctrls ));
|#
(defldap ldap-modify-ext-s (_fun _pointer
                                 _string
                                 (_array/list/zero _ldapmod/list)
                                 _pointer
                                 _pointer
                                 -> _int))

#|
LDAP_F( int )
ldap_passwd_s LDAP_P((
        LDAP           *ld,
        struct berval  *user,
        struct berval  *oldpw,
        struct berval  *newpw,
        struct berval  *newpasswd,
        LDAPControl   **sctrls,
        LDAPControl   **cctrls ));
|#
(defldap ldap-passwd-s (_fun _pointer
                             [user : _?]
                             [_berval-pointer = (make-berval
                                                 (string-length user)
                                                 user)]
                             [oldpw : _?]
                             [_berval-pointer = (make-berval
                                                 (string-length oldpw)
                                                 oldpw)]
                             [newpw : _?]
                             [_berval-pointer = (make-berval
                                                 (string-length newpw)
                                                 newpw)]
                             [_berval-pointer = (make-berval
                                                 (string-length newpw)
                                                 newpw)]
                             _pointer
                             _pointer
                             -> _int))

#|
LDAP_F( int )
ldap_rename_s LDAP_P((
        LDAP *ld,
        LDAP_CONST char *dn,
        LDAP_CONST char *newrdn,
        LDAP_CONST char *newSuperior,
        int deleteoldrdn,
        LDAPControl **sctrls,
        LDAPControl **cctrls ));
|#
(defldap ldap-rename-s (_fun _pointer
                             _string
                             _string
                             _string
                             _int
                             _pointer
                             _pointer
                             -> _int))

#|
LDAP_F( int )
ldap_delete_ext_s LDAP_P((
        LDAP             *ld,
        LDAP_CONST char  *dn,
        LDAPControl     **serverctrls,
        LDAPControl     **clientctrls ));

|#
(defldap ldap-delete-ext-s (_fun _pointer
                                 _string
                                 _pointer
                                 _pointer
                                 -> _int))

;; misc
(define (get-ber-value vals i)
  (berval-bv_val (ptr-ref vals _berval-pointer i)))