Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
104 lines (86 sloc) 3.55 KB
;;; Copyright © 2018 Roel Janssen <roel@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define-module (ldap authenticate)
#:use-module (ice-9 receive)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (system foreign)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (rnrs bytevectors)
#:use-module (logger)
#:re-export (%null-pointer parse-c-struct int size_t * pointer->string)
#:export (may-access?
ldap-is-available?))
;;
;; LIBRARY HANDLE
;; ----------------------------------------------------------------------------
(define %ldap-handle %null-pointer)
(define %glibc-handle (dynamic-link))
(define (ldap-link-library)
(catch 'misc-error
(lambda _
(set! %ldap-handle (dynamic-link (if (string= "@LIBLDAP@" "")
"libldap"
"@LIBLDAP@"))))
(lambda (key . args)
(set! %ldap-handle %null-pointer)
#f))
(dynamic-object? %ldap-handle))
(define (ldap-unlink-library)
(dynamic-unlink %ldap-handle))
(ldap-link-library)
(define (ldap-is-available?)
(dynamic-object? %ldap-handle))
;;
;; CONVENIENCE MACRO
;; ----------------------------------------------------------------------------
(define-syntax-rule
(define-foreign-function symbol handle return-type c-function args)
(define symbol
(if (eq? handle %null-pointer)
#f
(pointer->procedure return-type
(dynamic-func c-function handle) args))))
;;
;; LIBLDAP FUNCTIONS
;; ----------------------------------------------------------------------------
(define-foreign-function ldap-initialize
%ldap-handle int "ldap_initialize" '(* *))
(define-foreign-function ldap-simple-bind-synchronous
%ldap-handle int "ldap_simple_bind_s" '(* * *))
(define-foreign-function ldap-error->string
%ldap-handle '* "ldap_err2string" (list int))
(define-foreign-function ldap-unbind
%ldap-handle int "ldap_unbind" '(*))
;;
;; AUTHENTICATION FUNCTIONS
;; ----------------------------------------------------------------------------
(define (may-access? ldap-server-uri organizational-unit domain username password)
(let* ((connection (bytevector->pointer (make-bytevector (sizeof size_t))))
(bind-dn (format #f "cn=~a,ou=~a~{,dc=~a~}"
username
organizational-unit
(string-split domain #\.))))
(if (zero? (ldap-initialize connection (string->pointer ldap-server-uri)))
(let ((result (zero? (ldap-simple-bind-synchronous
(dereference-pointer connection)
(string->pointer bind-dn)
(string->pointer password)))))
(ldap-unbind (dereference-pointer connection))
result)
(begin
(log-error "may-access?" "Couldn't connect to ~s" ldap-server-uri)
#f))))
You can’t perform that action at this time.