diff options
Diffstat (limited to 'web/panettone/src/authentication.lisp')
| -rw-r--r-- | web/panettone/src/authentication.lisp | 204 |
1 files changed, 99 insertions, 105 deletions
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp index 3d4a3510ea05..291284b41619 100644 --- a/web/panettone/src/authentication.lisp +++ b/web/panettone/src/authentication.lisp @@ -3,113 +3,107 @@ (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))) +;; Migrating user authentication to OAuth2 necessitates some temporary +;; workarounds while other parts of the panettone code are being +;; amended appropriately. + +(defun fake-dn (username) + "Users are no longer read directly from LDAP, but everything in +panettone is keyed on the DNs. This function constructs matching +'fake' DNs." + (format nil "cn=~A,ou=users,dc=tvl,dc=fyi" username)) (defun find-user-by-dn (dn) - "Look up the user with the given DN in the LDAP database, returning an -instance of `user'" - (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=grfn,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)) - (conn (ldap:new-ldap :host (ldap:host *ldap*) - :port (ldap:port *ldap*) - :user dn - :pass password)) - (code-sym (nth-value 1 (unwind-protect (ldap:bind conn) - (ldap:unbind conn))))) - (when (equalp code-sym 'trivial-ldap:success) - user)))) + "Previously this function looked up users in LDAP based on their DN, +however panettone now does not have direct access to a user database. + +For most cases only the username is needed, which can be parsed out of +the user, however email addresses are temporarily not available." + (let ((username + (car (uiop:split-string (subseq dn 3) :separator '(#\,))))) + (make-instance + 'user + :dn dn + :cn username + :displayname username + :mail nil))) + +;; Implementation of standard OAuth2 authorisation flow. + +(defvar *oauth2-auth-endpoint* nil) +(defvar *oauth2-token-endpoint* nil) +(defvar *oauth2-client-id* nil) +(defvar *oauth2-client-secret* nil) + +(defvar *oauth2-redirect-uri* + (or (uiop:getenv "OAUTH2_REDIRECT_URI") + "https://b.tvl.fyi/auth")) + +(defun initialise-oauth2 () + "Initialise all settings needed for OAuth2" + + (setq *oauth2-auth-endpoint* + (or (uiop:getenv "OAUTH2_AUTH_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/auth")) + + (setq *oauth2-token-endpoint* + (or (uiop:getenv "OAUTH2_TOKEN_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/token")) + + (setq *oauth2-client-id* + (or (uiop:getenv "OAUTH2_CLIENT_ID") + "panettone")) + + (setq *oauth2-client-secret* + (or (uiop:getenv "OAUTH2_CLIENT_SECRET") + (error "OAUTH2_CLIENT_SECRET must be set!")))) + +(defun auth-url () + (format nil "~A?response_type=code&client_id=~A&redirect_uri=~A" + *oauth2-auth-endpoint* + (drakma:url-encode *oauth2-client-id* :utf-8) + (drakma:url-encode *oauth2-redirect-uri* :utf-8))) + +(defun claims-to-user (claims) + (let ((username (cdr (assoc :preferred--username claims))) + (email (cdr (assoc :email claims)))) + (make-instance + 'user + :dn (fake-dn username) + :cn username + :mail email + ;; TODO(tazjin): Figure out actual displayName mapping in tokens. + :displayname username))) + +(defun fetch-token (code) + "Fetches the access token on completion of user authentication through +the OAuth2 endpoint and returns the resulting user object." + + (multiple-value-bind (body status) + (drakma:http-request *oauth2-token-endpoint* + :method :post + :parameters `(("grant_type" . "authorization_code") + ("client_id" . ,*oauth2-client-id*) + ("client_secret" . ,*oauth2-client-secret*) + ("redirect_uri" . ,*oauth2-redirect-uri*) + ("code" . ,code)) + :external-format-out :utf-8 + :want-stream t) + (if (/= status 200) + (error "Authentication failed: ~A (~A)~%" + (alexandria:read-stream-content-into-string body) + status) + + ;; Returned JWT contains username and email, we can populate + ;; all fields from that. + (progn + (setf (flexi-streams:flexi-stream-external-format body) :utf-8) + (let* ((response (cl-json:decode-json body)) + (access-token (cdr (assoc :access--token response))) + (payload (cadr (uiop:split-string access-token :separator '(#\.)))) + (claims (cl-json:decode-json-from-string + (base64:base64-string-to-string payload)))) + (claims-to-user claims)))))) |