1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
(in-package :panettone.authentication)
(defvar *user* nil
"The currently logged-in user")
(defvar *ldap* nil
"The ldap connection")
(defvar *ldap-host* "localhost"
"The host for the ldap connection")
(defvar *ldap-port* 389
"The port for the ldap connection")
(defclass/std user ()
((cn dn mail displayname :type string)))
(defun connect-ldap (&key
(host "localhost")
(port 389))
(setq *ldap-host* host
*ldap-port* port
*ldap* (ldap:new-ldap :host host :port port)))
(defun reconnect-ldap ()
(setq *ldap* (ldap:new-ldap
:host *ldap-host*
:port *ldap-port*)))
(defmacro with-ldap ((&key (max-tries 1)) &body body)
"Execute BODY in a context where ldap connection errors trigger a reconnect
and a retry"
(with-gensyms (n try retry e)
`(flet
((,try
(,n)
(flet ((,retry (,e)
(if (>= ,n ,max-tries)
(error ,e)
(progn
(reconnect-ldap)
(,try (1+ ,n))))))
(handler-case
(progn
,@body)
(end-of-file (,e) (,retry ,e))
(trivial-ldap:ldap-connection-error (,e) (,retry ,e))))))
(,try 0))))
(defun ldap-entry->user (entry)
(apply
#'make-instance
'user
:dn (ldap:dn entry)
(alexandria:mappend
(lambda (field)
(list field (car (ldap:attr-value entry field))))
(list :mail
:cn
:displayname))))
(defun find-user/ldap (username)
(check-type username (simple-array character (*)))
(with-ldap ()
(ldap:search
*ldap*
`(and (= objectClass organizationalPerson)
(or
(= cn ,username)
(= dn ,username)))
;; TODO(grfn): make this configurable
:base "ou=users,dc=tvl,dc=fyi")
(ldap:next-search-result *ldap*)))
(defun find-user (username)
(check-type username (simple-array character (*)))
(when-let ((ldap-entry (find-user/ldap username)))
(ldap-entry->user ldap-entry)))
(defun find-user-by-dn (dn)
(with-ldap ()
(let ((have-results
(handler-case
(ldap:search *ldap* `(= objectClass organizationalPerson)
:base dn
:scope 'ldap:base)
; catch ldap-errors generated by trivial-ldap:parse-ldap-message
; since this is thrown on conditions which we don't want this
; function to fail like when there are no search results
(trivial-ldap:ldap-error (e) nil))))
(when have-results
(when-let ((ldap-entry (ldap:next-search-result *ldap*)))
(ldap-entry->user ldap-entry))))))
(comment
(find-user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
)
(defun authenticate-user (user-or-username password)
"Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind
request against the ldap server at *ldap*. Returns the user if authentication is
successful, `nil' otherwise"
(when-let ((user (if (typep user-or-username 'user) user-or-username
(find-user user-or-username))))
(let ((dn (dn user)))
(let ((code-sym
(nth-value 1 (ldap:bind
(ldap:new-ldap :host (ldap:host *ldap*)
:port (ldap:port *ldap*)
:user dn
:pass password)))))
(when (equalp code-sym 'trivial-ldap:success)
user)))))
|
