diff options
| -rw-r--r-- | web/panettone/default.nix | 1 | ||||
| -rw-r--r-- | web/panettone/src/authentication.lisp | 204 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 9 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 70 |
4 files changed, 119 insertions, 165 deletions
diff --git a/web/panettone/default.nix b/web/panettone/default.nix index a01e0d81c8..862dac95a8 100644 --- a/web/panettone/default.nix +++ b/web/panettone/default.nix @@ -16,7 +16,6 @@ depot.nix.buildLisp.program { lass local-time postmodern - trivial-ldap depot.lisp.klatre ]; diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp index 3d4a3510ea..291284b416 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)))))) diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index d3e23d5b33..a63f4c766a 100644 --- a/web/panettone/src/packages.lisp +++ b/web/panettone/src/packages.lisp @@ -23,9 +23,12 @@ (:import-from :defclass-std :defclass/std) (:import-from :alexandria :when-let :with-gensyms) (:export - :*user* :*ldap* + :*user* + :auth-url + :fetch-token :user :cn :dn :mail :displayname - :connect-ldap :find-user :find-user-by-dn :authenticate-user)) + :find-user-by-dn + :initialise-oauth2)) (defpackage panettone.model (:nicknames :model) @@ -81,4 +84,4 @@ :*pg-spec*) (:import-from :panettone.irc :send-irc-notification) (:shadow :next) - (:export :start-pannetone :config :main)) + (:export :start-panettone :config :main)) diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index bef5b018e4..f9ed979adc 100644 --- a/web/panettone/src/panettone.lisp +++ b/web/panettone/src/panettone.lisp @@ -78,7 +78,7 @@ (who:htm (:a :href (format nil - "/login?original-uri=~A" + "/auth?original-uri=~A" (drakma:url-encode (hunchentoot:request-uri*) :utf-8)) "Log In")))))) @@ -135,36 +135,6 @@ (when message (who:htm (:div :class "alert" (who:esc message)))))) -(defun render/login (&key message (original-uri "/")) - (render (:footer nil :header nil) - (:div - :class "login-form" - (:header - (:h1 "Login")) - (:main - :class "login-form" - (render/alert message) - (:form - :method :post :action "/login" - (:input :type "hidden" :name "original-uri" - :value (who:escape-string original-uri)) - (:div - (:label :for "username" - "Username") - (:input :type "text" - :name "username" - :id "username" - :placeholder "username")) - (:div - (:label :for "password" - "Password") - (:input :type "password" - :name "password" - :id "password" - :placeholder "password")) - (:input :type "submit" - :value "Submit")))))) - (defun render/settings () (let ((settings (model:settings-for-user (dn *user*)))) (render () @@ -434,7 +404,7 @@ given subject an body (in a thread, to avoid blocking)" (if-let ((*user* (hunchentoot:session-value 'user))) (funcall next) (hunchentoot:redirect - (format nil "/login?original-uri=~A" + (format nil "/auth?original-uri=~A" (drakma:url-encode (hunchentoot:request-uri*) :utf-8))))) @@ -457,20 +427,16 @@ given subject an body (in a thread, to avoid blocking)" (render/not-found (format nil "Issue #~A" (model:not-found-id err)))))) -(defroute login-form ("/login" :method :get) - (original-uri) - (if (hunchentoot:session-value 'user) - (hunchentoot:redirect (or original-uri "/")) - (render/login :original-uri original-uri))) +(defroute auth-handler ("/auth" :method :get :decorators (@auth-optional)) () + (if-let ((code (hunchentoot:get-parameter "code"))) + (let ((user (fetch-token code))) + (setf (hunchentoot:session-value 'user) user) + (hunchentoot:redirect (or (hunchentoot:session-value 'original-uri) "/"))) -(defroute submit-login ("/login" :method :post) - (&post original-uri username password) - (if-let ((user (authenticate-user username password))) (progn - (setf (hunchentoot:session-value 'user) user) - (hunchentoot:redirect (or original-uri "/"))) - (render/login :message "Invalid credentials" - :original-uri original-uri))) + (when-let ((original-uri (hunchentoot:get-parameter "original-uri"))) + (setf (hunchentoot:session-value 'original-uri) original-uri)) + (hunchentoot:redirect (authn:auth-url))))) (defroute logout ("/logout" :method :post) () (hunchentoot:delete-session-value 'user) @@ -641,13 +607,8 @@ given subject an body (in a thread, to avoid blocking)" (pomo:with-connection *pg-spec* (model:ddl/init))) -(defun start-panettone (&key port - (ldap-host "localhost") - (ldap-port 389) - session-secret) - (connect-ldap :host ldap-host - :port ldap-port) - +(defun start-panettone (&key port session-secret) + (authn:initialise-oauth2) (model:prepare-db-connections) (migrate-db) @@ -662,7 +623,6 @@ given subject an body (in a thread, to avoid blocking)" (defun main () (let ((port (integer-env "PANETTONE_PORT" :default 6161)) - (ldap-port (integer-env "LDAP_PORT" :default 389)) (cheddar-url (uiop:getenvp "CHEDDAR_URL")) (session-secret (uiop:getenvp "SESSION_SECRET"))) (when cheddar-url (setq *cheddar-url* cheddar-url)) @@ -670,7 +630,6 @@ given subject an body (in a thread, to avoid blocking)" (setq hunchentoot:*log-lisp-backtraces-p* nil) (start-panettone :port port - :ldap-port ldap-port :session-secret session-secret) (format t "launched panettone on port ~A~%" port) @@ -683,9 +642,8 @@ given subject an body (in a thread, to avoid blocking)" (comment (setq hunchentoot:*catch-errors-p* nil) - ;; to setup an ssh tunnel to ldap+cheddar+irccat for development: - ;; ssh -NL 3899:localhost:389 -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi + ;; to setup an ssh tunnel to cheddar+irccat for development: + ;; ssh -N -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi (start-panettone :port 6161 - :ldap-port 3899 :session-secret "session-secret") ) |