about summary refs log tree commit diff
path: root/web/panettone
diff options
context:
space:
mode:
Diffstat (limited to 'web/panettone')
-rw-r--r--web/panettone/default.nix1
-rw-r--r--web/panettone/src/authentication.lisp204
-rw-r--r--web/panettone/src/packages.lisp9
-rw-r--r--web/panettone/src/panettone.lisp70
4 files changed, 119 insertions, 165 deletions
diff --git a/web/panettone/default.nix b/web/panettone/default.nix
index a01e0d81c83a..862dac95a809 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 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))))))
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index d3e23d5b33ed..a63f4c766a1c 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 bef5b018e465..f9ed979adc79 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")
  )