From 6d42a5ea87524640ec222f59fec4cd8406ec30bf Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 18 Feb 2021 20:16:07 +0100 Subject: [PATCH] User registration moved from API backend to frontend, for spam prevention reasons --- README.md | 9 +++- configs/live.rkt | 2 + configs/pkgd.rkt | 13 ----- configs/tonyg.rkt | 3 ++ src/html-utils.rkt | 43 +++++++++------- src/site.rkt | 119 +++++++++++++++++++-------------------------- src/users.rkt | 82 +++++++++++++++++++++++++++++++ 7 files changed, 171 insertions(+), 100 deletions(-) delete mode 100644 configs/pkgd.rkt create mode 100644 src/users.rkt diff --git a/README.md b/README.md index 6b75927..fb1cd1e 100644 --- a/README.md +++ b/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: diff --git a/configs/live.rkt b/configs/live.rkt index 687e6b4..6f56acc 100644 --- a/configs/live.rkt +++ b/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 " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; To configure a split, S3-based setup, comment out the following lines: ;; diff --git a/configs/pkgd.rkt b/configs/pkgd.rkt deleted file mode 100644 index eb13aa6..0000000 --- a/configs/pkgd.rkt +++ /dev/null @@ -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/" - )) diff --git a/configs/tonyg.rkt b/configs/tonyg.rkt index 4565dc4..ee64772 100644 --- a/configs/tonyg.rkt +++ b/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: ;; diff --git a/src/html-utils.rkt b/src/html-utils.rkt index 15bfc31..1a8a9c6 100644 --- a/src/html-utils.rkt +++ b/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 ...)))] - [(_ bs ([name defaultval] rest ...)) - (define-form-bindings* bs ([name name defaultval] rest ...))] - [(_ bs (name rest ...)) - (define-form-bindings* bs ([name #f] rest ...))])) + (define-form-bindings* bs xform (rest ...)))] + [(_ bs xform ([name defaultval] rest ...)) + (define-form-bindings* bs xform ([name name defaultval] rest ...))] + [(_ bs xform (name 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 ...))) diff --git a/src/site.rkt b/src/site.rkt index c9281a4..9bf0683 100644 --- a/src/site.rkt +++ b/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) - (simple-json-rpc! #:sensitive? #t - #:include-credentials? #f - backend-baseurl - "/api/authenticate" - (hash 'email email - 'passwd password - 'code code))) - -(define (create-session-from-authentication-success! email password success) - ;; 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)])) +(define (create-session-after-authentication-success! email password) + (define user-facts + (simple-json-rpc! #:sensitive? #t + #:include-credentials? #f + backend-baseurl + "/api/authenticate" + (hash 'email email + 'passwd password))) + (when (not (hash? user-facts)) ;; Uh-oh. Something went wrong + (error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email)) (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)) - (if (or (equal? (string-trim email) "") - (equal? (string-trim password) "")) - (login-form "Please enter your email address and password.") - (match (authenticate-with-server! email password "") - [(or "wrong-code" (? eof-object?)) - (login-form "Something went awry; please try again.")] - [(or "emailed" #f) - (summarise-code-emailing "Incorrect password, or nonexistent user." email)] - [success - (create-session-from-authentication-success! email password success)]))) + (define-form-bindings/trim request (email password)) + (cond [(or (equal? email "") (equal? password "")) + (login-form "Please enter your email address and password.")] + [(not (login-password-correct? email password)) + (login-form "Incorrect password, or nonexistent user.")] + [else + (create-session-after-authentication-success! email password)])) (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) "") - (retry "Please enter your email address.")] - [(equal? (string-trim code) "") - (retry "Please enter the code you received in your email.")] - [(not (equal? password confirm_password)) - (retry "Please make sure the two password fields match.")] - [(equal? (string-trim password) "") - (retry "Please enter a password.")] - [else - (match (authenticate-with-server! email password code) - [(? eof-object?) - (retry "Something went awry. Please try again.")] - ["wrong-code" - (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)])])) + [(equal? email "") + (retry "Please enter your email address.")] + [(equal? code "") + (retry "Please enter the code you received in your email.")] + [(not (equal? password confirm_password)) + (retry "Please make sure the two password fields match.")] + [(equal? password "") + (retry "Please enter a password.")] + [(not (registration-code-correct? email code)) + (retry "The code you entered was incorrect. Please try again.")] + [else + (register-or-update-user! email password) + (create-session-after-authentication-success! email password)])) (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? - (summarise-code-emailing "Account registration/reset code emailed" email_for_code)])) - -(define (summarise-code-emailing reason email) - (with-site-config - (send/suspend/dispatch/dynamic - (lambda (embed-url) - (bootstrap-response reason - `(p - "We've emailed an account registration/reset code to " - (code ,email) ". Please check your email and then click " - "the button to continue:") - `(a ((class "btn btn-primary") - (href ,(embed-url (lambda (req) (register-form))))) - "Enter your code")))))) + (send-registration-or-reset-email! email_for_code) + (with-site-config + (send/suspend/dispatch/dynamic + (lambda (embed-url) + (bootstrap-response "Account registration/reset code emailed" + `(p + "We've emailed an account registration/reset code to " + (code ,email_for_code) ". Please check your email and then click " + "the button to continue:") + `(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) diff --git a/src/users.rkt b/src/users.rkt new file mode 100644 index 0000000..cba22e0 --- /dev/null +++ b/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)))