User registration moved from API backend to frontend, for spam prevention reasons

README.md

@@ -4,7 +4,9 @@
 
 You will need to install the following Racket packages:
 
-    raco pkg install --skip-installed reloadable
+    raco pkg install --skip-installed \
+         https://github.com/racket/infrastructure-userdb.git#main \
+         reloadable
 
 ## Configuration
 
@@ -50,6 +52,11 @@ Keys useful for deployment:
    statically. The source file `static.rkt` in this codebase knows
    precisely which files and directories within
    `pkg-index-generated-directory` to upload to the final site.
+ - *user-directory*: directory containing the user database; should be
+   the same as `pkg-index` uses.
+ - *email-sender-address*: string; defaults to `pkgs@racket-lang.org`.
+   Used as the "from" address when sending authentication emails on
+   behalf of the server.
 
 Keys useful for development:
 

configs/live.rkt

@@ -9,6 +9,8 @@
               (format "file://~a/public_html/pkg-index-static/pkgs-all.json.gz" var)
             'backend-baseurl "https://localhost:9004"
             'pkg-index-generated-directory (build-path var "public_html/pkg-index-static")
+            'user-directory (build-path var "pkg-index/users.new")
+            'email-sender-address "The Racket Package Server <pkgs@racket-lang.org>"
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; To configure a split, S3-based setup, comment out the following lines:
             ;;

configs/pkgd.rkt

@@ -1,13 +0,0 @@
-#lang racket/base
-;; Configuration for pkgd
-(require "../src/main.rkt")
-(main (hash 'port 8444
-            'backend-baseurl "https://localhost:9004"
-            'package-index-url "file:///home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/pkgs-all.json.gz"
-            'static-output-type 'aws-s3
-            'aws-s3-bucket+path "pkgn.racket-lang.org/"
-            'dynamic-urlprefix "https://pkgd.racket-lang.org/pkgn"
-            'static-urlprefix "https://pkgn.racket-lang.org"
-            'dynamic-static-urlprefix "https://pkgn.racket-lang.org"
-            'pkg-index-generated-directory "/home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/"
-            ))

configs/tonyg.rkt

@@ -9,6 +9,9 @@
             'ssl? #f
             'reloadable? #t
             'package-index-url (format "file://~a/pkgs-all.json.gz" pkg-index-generated-directory)
+            'user-directory (build-path (find-system-path 'home-dir)
+                                        "src/pkg-index/official/root/users.new")
+            'email-sender-address "tonyg@racket-lang.org"
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; Either:
             ;;

src/html-utils.rkt

@@ -1,10 +1,13 @@
 #lang racket/base
 ;; A utilities module :-/
 
-(require web-server/servlet)
-
 (provide maybe-splice
-	 define-form-bindings)
+         define-form-bindings/xform
+	 define-form-bindings
+         define-form-bindings/trim)
+
+(require web-server/servlet)
+(require (only-in racket/string string-trim))
 
 ;; Boolean XExpr ... -> (Listof XExpr)
 ;; Useful for optionally splicing in some contents to a list.
@@ -12,22 +15,28 @@
 (define-syntax-rule (maybe-splice guard contents ...)
   (if guard (list contents ...) '()))
 
-;; Extracts named single-valued bindings from the given request.
-;; If a given binding is missing, the extracted value will be #f.
-(define-syntax-rule (define-form-bindings req (specs ...))
-  (begin (define bs (request-bindings req))
-         (define-form-bindings* bs (specs ...))))
-
 (define-syntax define-form-bindings*
   (syntax-rules ()
-    [(_ bs ())
+    [(_ bs xform ())
      (begin)]
-    [(_ bs ([name fieldname defaultval] rest ...))
+    [(_ bs xform ([name fieldname defaultval] rest ...))
      (begin (define name (if (exists-binding? 'fieldname bs)
-                             (extract-binding/single 'fieldname bs)
+                             (xform (extract-binding/single 'fieldname bs))
                              defaultval))
-            (define-form-bindings* bs (rest ...)))]
+            (define-form-bindings* bs xform (rest ...)))]
-    [(_ bs ([name defaultval] rest ...))
+    [(_ bs xform ([name defaultval] rest ...))
-     (define-form-bindings* bs ([name name defaultval] rest ...))]
+     (define-form-bindings* bs xform ([name name defaultval] rest ...))]
-    [(_ bs (name rest ...))
+    [(_ bs xform (name rest ...))
-     (define-form-bindings* bs ([name #f] rest ...))]))
+     (define-form-bindings* bs xform ([name #f] rest ...))]))
+
+;; Extracts named single-valued bindings from the given request.
+;; If a given binding is missing, the extracted value will be #f.
+(define-syntax-rule (define-form-bindings/xform req xform (specs ...))
+  (begin (define bs (request-bindings req))
+         (define-form-bindings* bs xform (specs ...))))
+
+(define-syntax-rule (define-form-bindings req (specs ...))
+  (define-form-bindings/xform req values (specs ...)))
+
+(define-syntax-rule (define-form-bindings/trim req (specs ...))
+  (define-form-bindings/xform req string-trim (specs ...)))

src/site.rkt

@@ -10,7 +10,7 @@
 (require racket/match)
 (require racket/format)
 (require racket/date)
-(require racket/string)
+(require (only-in racket/string string-join string-split))
 (require racket/port)
 (require (only-in racket/list filter-map drop-right))
 (require (only-in racket/exn exn->string))
@@ -32,6 +32,7 @@
 (require "package-source.rkt")
 (require "http-utils.rkt")
 (require "challenge.rkt")
+(require "users.rkt")
 
 (define static-urlprefix
   (or (@ (config) static-urlprefix)
@@ -358,38 +359,28 @@
                                              (p ,error-message))))
                             ,(form-group 4 5 (primary-button "Log in"))))))))
 
-(define (authenticate-with-server! email password code)
+(define (create-session-after-authentication-success! email password)
-  (simple-json-rpc! #:sensitive? #t
+  (define user-facts
-                    #:include-credentials? #f
+    (simple-json-rpc! #:sensitive? #t
-                    backend-baseurl
+                      #:include-credentials? #f
-                    "/api/authenticate"
+                      backend-baseurl
-                    (hash 'email email
+                      "/api/authenticate"
-                          'passwd password
+                      (hash 'email email
-                          'code code)))
+                            'passwd password)))
-
+  (when (not (hash? user-facts)) ;; Uh-oh. Something went wrong
-(define (create-session-from-authentication-success! email password success)
+    (error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email))
-  ;; An "authentication success" is either #t, signalling a new user,
-  ;; or a hash-table with interesting facts in it.
-  (define user-facts (cond [(eq? success #t) (hasheq)]
-                           [(hash? success) success]
-                           [else (log-warning "Bad auth success for user ~v: ~v" email success)
-                                 (hasheq)]))
   (create-session! email password
                    #:curator? (if (hash-ref user-facts 'curation #f) #t #f)
                    #:superuser? (if (hash-ref user-facts 'superuser #f) #t #f)))
 
 (define (process-login-credentials request)
-  (define-form-bindings request (email password))
+  (define-form-bindings/trim request (email password))
-  (if (or (equal? (string-trim email) "")
+  (cond [(or (equal? email "") (equal? password ""))
-          (equal? (string-trim password) ""))
+         (login-form "Please enter your email address and password.")]
-      (login-form "Please enter your email address and password.")
+        [(not (login-password-correct? email password))
-      (match (authenticate-with-server! email password "")
+         (login-form "Incorrect password, or nonexistent user.")]
-        [(or "wrong-code" (? eof-object?))
+        [else
-         (login-form "Something went awry; please try again.")]
+         (create-session-after-authentication-success! email password)]))
-        [(or "emailed" #f)
-         (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
-        [success
-         (create-session-from-authentication-success! email password success)])))
 
 (define (register-form #:email [email ""]
                        #:email_for_code [email_for_code ""]
@@ -465,45 +456,38 @@
                                   ,(form-group 4 5 (primary-button "Continue")))))))))
 
 (define (apply-account-code request)
-  (define-form-bindings request (email code password confirm_password))
+  (define-form-bindings/trim request (email code password confirm_password))
   (define (retry msg)
     (register-form #:email email
                    #:code code
                    #:step2-error-message msg))
   (cond
-   [(equal? (string-trim email) "")
+    [(equal? email "")
-    (retry "Please enter your email address.")]
+     (retry "Please enter your email address.")]
-   [(equal? (string-trim code) "")
+    [(equal? code "")
-    (retry "Please enter the code you received in your email.")]
+     (retry "Please enter the code you received in your email.")]
-   [(not (equal? password confirm_password))
+    [(not (equal? password confirm_password))
-    (retry "Please make sure the two password fields match.")]
+     (retry "Please make sure the two password fields match.")]
-   [(equal? (string-trim password) "")
+    [(equal? password "")
-    (retry "Please enter a password.")]
+     (retry "Please enter a password.")]
-   [else
+    [(not (registration-code-correct? email code))
-    (match (authenticate-with-server! email password code)
+     (retry "The code you entered was incorrect. Please try again.")]
-      [(? eof-object?)
+    [else
-       (retry "Something went awry. Please try again.")]
+     (register-or-update-user! email password)
-      ["wrong-code"
+     (create-session-after-authentication-success! email password)]))
-       (retry "The code you entered was incorrect. Please try again.")]
-      [(or "emailed" #f)
-       (retry "Something went awry; you have been emailed another code. Please check your email.")]
-      [success
-       ;; The email and password combo we have been given is good to go.
-       ;; Set a cookie and consider ourselves logged in.
-       (create-session-from-authentication-success! email password success)])]))
 
 (define ((check-challenge challenge) request)
-  (define-form-bindings request (email_for_code question_answer))
+  (define-form-bindings/trim request (email_for_code question_answer))
   (define (retry msg-a msg-b)
     (register-form #:email_for_code email_for_code
                    #:step1a-error-message msg-a
                    #:step1b-error-message msg-b))
   (cond
-    [(equal? (string-trim email_for_code) "")
+    [(equal? email_for_code "")
      (log-info "REGISTRATION/RESET EMAIL: address missing")
      (retry "Please enter your email address."
             "Don't forget to answer the new question!")]
-    [(equal? (string-trim question_answer) "")
+    [(equal? question_answer "")
      (log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
      (retry #f
             "Please answer the anti-spam question. (It changes each time!)")]
@@ -523,21 +507,18 @@
      (log-info "  ✓ expected answer: ~v" (~a (challenge-answer challenge)))
      (log-info "  ✓ provided answer: ~v" question_answer)
      (log-info "  ✓ HTTP request details: ~v" request)
-     (authenticate-with-server! email_for_code "" "") ;; TODO check result?
+     (send-registration-or-reset-email! email_for_code)
-     (summarise-code-emailing "Account registration/reset code emailed" email_for_code)]))
+     (with-site-config
-
+       (send/suspend/dispatch/dynamic
-(define (summarise-code-emailing reason email)
+        (lambda (embed-url)
-  (with-site-config
+          (bootstrap-response "Account registration/reset code emailed"
-   (send/suspend/dispatch/dynamic
+                              `(p
-    (lambda (embed-url)
+                                "We've emailed an account registration/reset code to "
-      (bootstrap-response reason
+                                (code ,email_for_code) ". Please check your email and then click "
-                          `(p
+                                "the button to continue:")
-                            "We've emailed an account registration/reset code to "
+                              `(a ((class "btn btn-primary")
-                            (code ,email) ". Please check your email and then click "
+                                   (href ,(embed-url (lambda (req) (register-form)))))
-                            "the button to continue:")
+                                  "Enter your code")))))]))
-                          `(a ((class "btn btn-primary")
-                               (href ,(embed-url (lambda (req) (register-form)))))
-                            "Enter your code"))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -1324,7 +1305,7 @@
 
 (define ((update-draft draft0) request)
   (define draft (read-draft-form draft0 (request-bindings request)))
-  (define-form-bindings request (action new_version))
+  (define-form-bindings/trim request (action new_version))
   (match action
     ["save_changes"
      (if (save-draft! draft)
@@ -1336,7 +1317,7 @@
                        draft))]
     ["add_version"
      (cond
-      [(equal? (string-trim new_version) "")
+      [(equal? new_version "")
        (package-form "Please enter a version number to add." draft)]
       [(assoc new_version (draft-package-versions draft))
        (package-form (format "Could not add version ~a, as it already exists." new_version)

src/users.rkt

@@ -0,0 +1,82 @@
+#lang racket/base
+;; User management - userdb, plus registration and emailing
+
+(provide login-password-correct?
+         send-registration-or-reset-email!
+         registration-code-correct?
+         register-or-update-user!)
+
+(require net/sendmail)
+(require reloadable)
+(require infrastructure-userdb)
+(require "config.rkt")
+(require "hash-utils.rkt")
+
+(define-logger racket-pkg-website/users)
+
+(define userdb (userdb-config (@ (config) user-directory)
+                              #t ;; writeable!
+                              ))
+
+(define *codes*
+  (make-persistent-state '*codes* (lambda () (make-registration-state))))
+
+(define (login-password-correct? email given-password)
+  (log-racket-pkg-website/users-info "Checking password for ~v" email)
+  (user-password-correct? (lookup-user userdb email) given-password))
+
+(define (send-registration-or-reset-email! email)
+  (if (user-exists? userdb email)
+      (send-password-reset-email! email)
+      (send-account-registration-email! email)))
+
+(define (sender-address)
+  (or (@ (config) user-directory)
+      "pkgs@racket-lang.org"))
+
+(define (send-password-reset-email! email)
+  (log-racket-pkg-website/users-info "Sending password reset email to ~v" email)
+  (send-mail-message
+   (sender-address)
+   "Account password reset for Racket Package Catalog"
+   (list email)
+   '()
+   '()
+   (list
+    "Someone tried to login with your email address for an account on the Racket Package Catalog, but failed."
+    "If this was you, please use this code to reset your password:"
+    ""
+    (generate-registration-code! (*codes*) email)
+    ""
+    "This code will expire, so if it is not available, you'll have to try again.")))
+
+(define (send-account-registration-email! email)
+  (log-racket-pkg-website/users-info "Sending account registration email to ~v" email)
+  (send-mail-message
+   (sender-address)
+   "Account confirmation for Racket Package Catalog"
+   (list email)
+   '()
+   '()
+   (list
+    "Someone tried to register your email address for an account on the Racket Package Catalog."
+    "If you want to proceed, use this code:"
+    ""
+    (generate-registration-code! (*codes*) email)
+    ""
+    "This code will expire, so if it is not available, you'll have to try to register again.")))
+
+(define (registration-code-correct? email given-code)
+  (log-racket-pkg-website/users-info "Checking registration code for ~v" email)
+  (check-registration-code (*codes*)
+                           email
+                           given-code
+                           (lambda () #t)
+                           (lambda () #f)))
+
+(define (register-or-update-user! email password)
+  (log-racket-pkg-website/users-info "Updating user record ~v" email)
+  (save-user! userdb
+              (user-password-set (or (lookup-user userdb email)
+                                     (make-user email password))
+                                 password)))