Skip to content
This repository has been archived by the owner. It is now read-only.
Permalink
main
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
;;; 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 format)
#:use-module (srfi srfi-1)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (logger)
#:use-module (www config)
#: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 (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-set-option
%ldap-handle int "ldap_set_option" `(* ,int *))
(define-foreign-function ldap-error->string
%ldap-handle '* "ldap_err2string" (list int))
(define-foreign-function ldap-unbind
%ldap-handle int "ldap_unbind" '(*))
;;
;; LIBLDAP CONSTANTS
;; ----------------------------------------------------------------------------
(define LDAP_VERSION3 (make-c-struct (list int) (list 3)))
(define LDAP_OPT_PROTOCOL_VERSION 17)
(define LDAP_OPT_X_TLS_CACERTFILE 24578)
(define LDAP_OPT_X_TLS_CACERTDIR 24579)
;;
;; AUTHENTICATION FUNCTIONS
;; ----------------------------------------------------------------------------
(define (may-access? ldap-server-uri common-name organizational-unit domain
username password)
(catch 'ldap-error
(lambda _
(let* ((connection (bytevector->pointer
(make-bytevector (sizeof size_t))))
(bind-dn (string-append "cn=" username
(if common-name
(format #f "~{,~a~}"
(map (lambda (cn)
(string-append "cn=" cn))
(string-split common-name #\.)))
"")
(if organizational-unit
(format #f ",ou=~a" organizational-unit)
"")
(format #f "~{,dc=~a~}"
(string-split domain #\.)))))
(when (ldap-ssl-certificate-directory)
(unless (zero? (ldap-set-option (dereference-pointer connection)
LDAP_OPT_X_TLS_CACERTDIR
(string->pointer
(ldap-ssl-certificate-directory))))
(throw 'ldap-error "Cannot set SSL certificate directory.")))
(when (ldap-ssl-certificate-file)
(unless (zero? (ldap-set-option (dereference-pointer connection)
LDAP_OPT_X_TLS_CACERTFILE
(string->pointer
(ldap-ssl-certificate-file))))
(throw 'ldap-error "Cannot set SSL certificate file.")))
(if (zero? (ldap-initialize connection (string->pointer ldap-server-uri)))
(begin
(unless (zero? (ldap-set-option (dereference-pointer connection)
LDAP_OPT_PROTOCOL_VERSION
LDAP_VERSION3))
(throw 'ldap-error "Cannot set protocol version."))
(let [(result (ldap-simple-bind-synchronous
(dereference-pointer connection)
(string->pointer bind-dn)
(string->pointer password)))]
(ldap-unbind (dereference-pointer connection))
(zero? result)))
(throw 'ldap-error "Couldn't connect to ~s" ldap-server-uri))))
(lambda (key . args)
(log-error "may-access?" "~s" args)
#f)))