blob: e4f893f8833063c1c105fc79bdf61f2de7e28908 (
plain) (
blame)
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
|
(in-package :panettone.authentication)
(defvar *user* nil
"The currently logged-in user")
(defvar *ldap* nil
"The ldap connection")
(defclass/std user ()
((cn dn mail displayname :type string)))
(defun connect-ldap (&key
(host "localhost")
(port 389))
(setq *ldap* (ldap:new-ldap :host host :port port)))
(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 (*)))
(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)
(ldap:search *ldap* `(= objectClass organizationalPerson)
:base dn
:scope 'ldap:base)
(when-let ((ldap-entry (ldap:next-search-result *ldap*)))
(ldap-entry->user ldap-entry)))
(comment
(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)))))
|
